Number: 401 Title: Imperative types in SML/NJ 0.66 Keywords: types, weak types, polymorphism Submitter: Dave Berry Date: 2/14/91 Version: 0.66 System: Severity: Problem: The following program compiles under Poly/ML 1.86, but fails to compile under SML/NJ 0.66. fun create (x:int) (y:'_a) :'_a Array.array = Array.array (x, y) type ('a,'b) table = ('a*int*'b) list Array.array val defaultSize = 97 fun createDefault (sample'value :'_a) :(string, '_a) table = let val mt = [] : (string * int * '_a) list in create defaultSize mt end It will compile if Array.array is used directly in place of the curried version. It will also compile if createDefault is given an extra parameter, either before or after the existing one. This is the simplest example I've run across of SML/NJ failing to type correct SML use of imperative types. It's fairly simple in this case - it only took me a day to get the case this simple - but I've come across at least one other example that I've just given up on. I remember Dave MacQueen and mads Tofte discussing a bug in the SML/NJ algorithm at the Edinburgh Workshop. Is there any chance of a fix? Dave. From: jhr@cs.cornell.edu (John Reppy) This problem was pointed out by Jim O'Toole. Anyway, it was fixed in 0.67: Standard ML of New Jersey, Version 0.68-JHR, January 25, 1991 val it = () : unit - fun create (x:int) (y:'_a) :'_a Array.array = Array.array (x, y) = type ('a,'b) table = ('a*int*'b) list Array.array = val defaultSize = 97 = fun createDefault (sample'value :'_a) :(string, '_a) table = = let val mt = [] : (string * int * '_a) list = in create defaultSize mt = end; val create = fn : int -> '1a -> '1a array type ('a,'b) table = ('a * int * 'b) list array val defaultSize = 97 : int val createDefault = fn : '1a -> (string,'1a) table - Status: fixed in 0.67 --------------------------------------------------------------------------- Number: 402 Title: local non-declarations Keywords: Submitter: Bernard Berthomieu (bernard@laas.laas.fr) Date: 30/1/90 Version: 0.66 System: SUN Sparstation 1+, SunOS 4.0.3c Severity: minor Problem: some declarations not accepted Code: local val x = 5 in 20 + x end; Transcript: - local val x = 5 in 20 + x end; std_in:1.21 Error: syntax error found at INT Comments: Not sure this is a bug, but the SML documents are not clear about this. According to my interpretation of the standard grammar, this declaration should be equivalent to the following: - local val x = 5 in val it = 20 + x end; val it = 25 : int Fix: expressions are considered as declarations ONLY at top level. Status: not a bug --------------------------------------------------------------------------- Number: 403 Title: 0.0/0.0 not properly handled on Sparc Keywords: Submitter: Bernard Berthomieu (bernard@laas.laas.fr) Date: 30/1/90 Version: 0.66 System: SUN Sparstation 1+, SunOS 4.0.3c Severity: minor Problem: 0.0/0.0 not properly handled Code: 0.0/0.0 Transcript: - 0.0/0.0; strange floating point error (* and sml exits *) Comments: 0.0/0.0 is generally considered in implementations of reals as an "invalid operation" rather than a "division by zero" (exception code FPE_FLTOPERR_TRAP on SUNs OS 4.0). I did not checked the effect of 0.0/0.0 on other targets than SUN 4s, but it might have strange effects too; Submitter: Josh Hodas (hodas@cs.hmc.edu) Date: 3/6/95 System(s) and Version: ??? SML/NJ Version: 0.93 Machine: Sparc 1000 / SunOs 5.3 Severity: minor Problem: The 0.0/0.0 bug that generates "strange floating point error 0x7" and exits to unix, which was (according to the master bugs file) fixed in 0.68 has returned. Code: 0.0/0.0; Transcript: Standard ML of New Jersey, Version 0.93, February 15, 1993 val it = () : unit - 0.0/0.0; strange floating point error, 0x7 Owner: John Status: obsolete [new basis] --------------------------------------------------------------------------- Number: 404 Title: std_out not flushed on read from std_in Keywords: Submitter: Kim Dam Petersen (kimdam@sun.tfl.dk) Date: 6/1/91 Version: 0.66 System: all Severity: minor Problem: std_out not flushed on read from std_in Comments: As printing on the standard output and error streams usually are flushed automatically I would suggest that this should be part of the standard behaviour of these stream. It seems that NJ/ML delays output flushing until the computation of a top level expression has completed. As mentioned above flushing should be performed immediately. A temporary solution in NJ/ML is to redefine the `output' function, such that the predefined `flush_out' is automatically called: val output = fn(s,t) => (output(s,t); flush_out s) Future call of `output' will print the text immediately. Status: fixed in 0.71 --------------------------------------------------------------------------- Number: 405 Title: identifiers starting with underscores are incorrectly allowed Keywords: Submitter: Mick Francis (Abstract Hardware) Date: 8/1/91 Version: 0.66 System: all Severity: minor Problem: identifiers starting with underscores are incorrectly allowed Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 406 Title: funny signatures in 0.71 Keywords: Submitter: John Reppy Date: 8/1/91 Version: 0.71 System: all Severity: minor Problem: Array.tabulate and String.chr have wrong types in initial environment Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 407 Title: create_v_v for SPARC Keywords: Submitter: Juergen Buntrock TUB, jubu@cs.tu-berlin.de Date: 9/24/91 Version: 0.73 System: sun4c SUNOS 4.1.1 Severity: major Problem: The mask is not set in create_v_v (SPARC.prim.s) segmentation fault in collect_roots in callgc.c Fix: diff -c SPARC.prim.s.org SPARC.prim.s *** SPARC.prim.s.org Fri Aug 23 20:33:54 1991 --- SPARC.prim.s Tue Sep 24 19:11:30 1991 *************** *** 476,481 **** --- 476,483 ---- nop 4: CONTINUE + .word closmask /* reg. mask */ + .word 0 3: add %g0,0,%g0 /* nop to get PC adjust right */ Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 408 Title: feedback from module system Keywords: Submitter: tmb@ai.mit.edu Date: 08/03/91 Version: 0.70 System: Sun4/OS4.1.1 Severity: cosmetic, but important I have been playing around with building functors that abstract various notions of "iteration", "array", "sequence", and "index" (ultimately, this will hopefully provide a nicer alternative to the equivalent data structures in the current SML library). In general, using the ML module and type system for this seems straightforward and natural, and I'm much more pleased with the way I can design this code in SML than with similar code that I have written in Scheme, CommonLisp, and C++. However, I have also come across some cosmetic but (to me) important problems with the NJ/SML module system. Some of the problems are that the system isn't telling me enough about the identity of objects to allow me to debug the code without having to guess much; something analogous to the LispMachine inspector and mouse sensitivity would ultimately be very useful, but for the time being, just reporting unique tags for objects instead of "?" would be sufficient. Some of this might also be a question of style, but my ignorance is partially due to the fact that the only uses of the module system that I have seen have been rather simple and straightforward (even if they involve lots of code). I'd appreciate your feedback. Thanks, Thomas. PS: I can send you the complete code if you are interested, but it is still more of a sketch or prototype. = 1 ================================================================ I have a functor which generates iteration constructs for some data type that it is handed (e.g., it generates "fold", "apply", etc. for lists and arrays). It is very confusing that the types that the system reports for the functions generated by this functor involve types of the form "('a,'b) value" and "('a,'b) index". It would be much better if the types were reported in their true form. signature S = sig type ('a,'b) data end; functor F(structure X:S) = struct fun f(x:('a,'b) X.data):('a,'b) X.data = x end; structure A = struct type ('a,'b) data = 'b list end; structure B = F(structure X=A); - B.f([1]); val it = [1] : ('a,int) A.data - What I would want is: - B.f([1]); val it = [1] : int list - Obviously, which form one wants depends on the exact use that a functor is going to be put to. There should be a mechanism for me to specify in the type binding which form of reporting I prefer. = 2 ================================================================ Another problem that I have encountered is that it is nearly impossible to figure out what goes wrong with complicated functor applications with the current level of reporting: elements of intermediate structures are now often only reported as "?.KeyIndexing.foo", and it isn't helpful if the compiler tells you that "?.KeyIndexing.foo" is a different type from "?.KeyIndexing.foo". It would be much more convenient if there was an option to the compiler that would trace and report functor applications, and if the printer gave unique identities to structures, even temporary ones. Something like: - use "foo"; [Applying functor F<10> to structure <1001> giving structure <347> bound to structure T] [Applying functor G<11> to structure <66> giving structure <67> bound to structure T.M] [Applying functor G<11> to structure <33> giving structure <68> bound to structure T.M] - T.i; val it = SOMETHING : <11>.my_type; - Printing unique ID's for structures (and, for that matter, for other objects) shouldn't be hard, and it makes debugging so much easier. = 3 ================================================================ When writing signatures for functors that generate polymorphic functions, I seem to have to define types that carry around one type variable for each polymorphic type, e.g.: signature BASICACCESS = sig type ('a,'b) point type ('a,'b) value type ('a,'b) index type ('a,'b) range val first: ('a,'b) range -> ('a,'b) index val succ: ('a,'b) index -> ('a,'b) index val done: ('a,'b) index -> bool val mkindex: ('a,'b) point * ('a,'b) range -> ('a,'b) index val at: ('a,'b) index -> ('a,'b) value end; Most of the polymorphic functions that get generated from BASICACCESS structures will never need both type variables, while others may need more than two. For example, structure BasicListIndex = struct type ('a,'b) point = 'a list type ('a,'b) value = 'a type ('a,'b) index = 'a list type ('a,'b) range = 'a list fun first x = x val succ = tl val done = null fun mkindex(x,y) = x fun at x = System.Unsafe.cast (hd x) (* bug in NJSML .70 type checker ? *) end; structure BasicArrayIndex = struct type ('a,'b) point = int type ('a,'b) index = int * int type ('a,'b) range = int fun first(limit:('a,'b) range):('a,'b) index = (0,limit) fun succ((x,limit):('a,'b) index):('a,'b) index = (x+1,limit) fun done((x,limit):('a,'b) index):bool = x>=limit fun at x = x fun mkindex(x,r) = (x,r) fun index1((x,_):('a,'b) index) = x end; Carrying around the dummy type variables on types like "('a,'b) point" is a bother. Perhaps a simple solution would be to allow the user to omit type variables if they are specified as wildcards, e.g., "type ('_,'_) point = int" can be used simply as "val x : point" with the compiler inserting the missing (wildcard) type variables by convention. More generally, it would seem to be nice if type constructors could take variable numbers of arguments, and if they could pass their argument lists around as complete entities (analogous to passing around tuples of arguments in ML). Another possibility would be to allow "free" type variables: type point = '_ list This would simply be syntactic sugar for type 'a point = 'a list and the compiler would implicitly provide a dummy argument to "point" wherever it is used. However, this may break other parts of the type or module system. Point 3 is really about a basic problem with the current way signatures and functors handle types, not about "'_". Essentially, I want to write functors that generate objects that are polymorphic in different ways, e.g., that sometimes generate a function "f : 'a -> 'a" and sometimes "f : 'a -> 'b". The only way I could find of writing signatures for such functors is to make both the LHS and the RHS types (e.g. type ('a,'b) arg; type ('a,'b) result) that depend on two type variables and instantiate them in the matching structures to the correct types. This causes a number of problems that I mentioned in my previous message. Another possibility would be to allow a function of type "'a -> 'a" to match a type specification "'a -> 'b", but that does not currently work. Functors that generate functions that are polymorphic in different ways are very important, and, one way or another, SML must make this more convenient than it is right now. Thanks, Thomas. = 4 ================================================================ A related problem is that nongeneric weak type variables generate an error even if they are never used: - val x: '0a t = 3; std_in:3.1-3.16 Error: nongeneric weak type variable x : '0aU t - I think you can guess from the above structures and functors how such non-generic weak type variables can pop up unexpectedly (they are easy to fix for the user, by simply giving a type to the value, but it seems odd for a user of, say structure "Array2D" to have to specify some type as "(unit,int) array" just to create an array of type "int array"). = 5 ================================================================ A minor problem with wildcard type variables: - type ('_,'_) a; std_in:7.7-7.11 Error: duplicate type variable: '1 std_in:7.7-7.11 Error: duplicate type variable: '1 std_in:7.7-7.11 Error: duplicate type variable: '1 std_in:7.7-7.11 Error: duplicate type variable: '1 std_in:7.7-7.11 Error: duplicate type variable: '1 - I think the "'_" should refer to a new type variable every time it is used (this is, after all, what "_" does in ML). Followup discussion: Dave MacQueen writes: > What you are looking for may be rather difficult to do within the > framework of the ML type system. At first glance it appears to > require a serious innovation in the type system to capture an > abstraction that could instantiate to both "f : 'a -> 'a" and > "f : 'a -> 'b" (note that these two types have different numbers of > bound variables). > > Do you have any suggestions as to how this could be done? I believe it is possible to express type constraints like this with SML: signature S = sig type ('a,'b) from type ('a,'b) to val f : ('a,'b) from -> ('a,'b) to end; structure X:S = struct type ('a,'b) from = 'a type ('a,'b) to = 'a fun f(x) = x end; structure Y:S = struct type ('a,'b) from = 'a * 'b type ('a,'b) to = 'a fun f(x,y) = x end; (These are actually not accepted by NJ/SML 0.70, even if the types for "f" are fully specified in the structure definitions (you get a different error message in that case), but I think that's a bug.) The main problem is that this use of types in signatures seems to have been rather uncommon so far, so, at least NJ/SML has several difficulties with it: * the type checker/module system (incorrectly?) rejects some constructs like this * unused type variables need to be instantiated by the user when they become weak; instead, the language could automatically define such variables to be "unit" * the type constructors "from" and "to" are really auxilliary, and users of S most likely never want to see them printed; the current system prints them * the writer of the signature "S" has to pick a maximum number of auxilliary type variables used as arguments to "from" and "to", but I believe that the actual maximum number needed depends on the arguments given to the functor, not on the functor itself I want to state again that I think this feature is important. Without the ability to specify signatures that can match structures that are polymorphic in different ways, it seems I would have to write completely redundant versions of some functors. The context in which it came up was writing a functor that generates iteration constructs for collections; for some collections, indexes and values are different types, for others, they are the same type. Status: not a bug --------------------------------------------------------------------------- Number: 409 Title: type checking after functor application Keywords: Submitter: tmb@ai.mit.edu Date: 08/05/91 Version: 0.70 System: Sun4/OS4.1.1 Severity: ? Problem: Basically, I have something like: functor F(...) = struct structure A = G(...); ... open A end; structure X = F(...); X.A.f arg; --> works X.f arg; --> fails with a type error Comment: X.A.f and X.f must refer to the same value with the same type: A has simply been opened at the end of structure X. I don't see how X.f could ever behave differently from X.A.f. Sorry about the long code needed to reproduce the bug. I had several guesses what the problem might be due to, but I have not been able to reduce the code further than this. In particular, the problem goes away if the last functor application is removed, i.e., functor GeneralArray(structure Index:BASICACCESS) = struct ... end; structure Arrays = GeneralArray(structure Index = BasicArrayIndex); is replaced with structure Arrays = struct structure Index:BASICACCESS = BasicArrayIndex ... body of functor GeneralArray ... end Also, don't try to make sense of the code. To isolate the bug this far, I collapsed several types. Code: (file foo.sml) signature BASICACCESS = sig type ('a,'b) index type ('a,'b) range val first: ('a,'b) range -> ('a,'b) index val succ: ('a,'b) index -> ('a,'b) index val done: ('a,'b) index -> bool end; functor GeneralIteration(structure Access:BASICACCESS) = struct local open Access in fun apply f r = let fun loop(i) = if done(i) then () else (f(i); loop(succ(i))) in loop(first(r)) end end end; functor GeneralArray(structure Index:BASICACCESS) = struct type ('a,'b) array = 'b Array.array * ('a,'b) Index.range structure ValueIndex = struct type ('a,'b) range = ('a,'b) array type ('a,'b) index = 'b Array.array * ('a,'b)Index.index fun first((a,r):('a,'b) range) = (a,Index.first(r)) fun succ((a,r):('a,'b) index) = (a,Index.succ(r)) fun done((a,r):('a,'b) index) = Index.done(r) end structure Value = GeneralIteration(structure Access = ValueIndex) fun array(r:(unit,'1b) Index.range,initial):(unit,'1b) array = (Array.array(100,initial),r) open Value end; structure BasicArrayIndex = struct type ('a,'b) index = int * int type ('a,'b) range = int fun first(limit:('a,'b) range):('a,'b) index = (0,limit) fun succ((x,limit):('a,'b) index):('a,'b) index = (x+1,limit) fun done((x,limit):('a,'b) index):bool = x>=limit end; structure Arrays = GeneralArray(structure Index = BasicArrayIndex); Transcript: volterra$ sml Standard ML of New Jersey, Version 0.70, 1 July 1991 val it = () : unit - use "foo.sml"; [opening foo.sml] signature BASICACCESS = sig type ('a,'b) index type ('a,'b) range val done : ('a,'b) index -> bool val first : ('a,'b) range -> ('a,'b) index val succ : ('a,'b) index -> ('a,'b) index end functor GeneralIteration : functor GeneralArray : structure BasicArrayIndex : sig eqtype ('a,'b) index eqtype ('a,'b) range val done : ('a,'b) index -> bool val first : ('a,'b) range -> ('a,'b) index val succ : ('a,'b) index -> ('a,'b) index end structure Arrays : sig structure Value : sig...end structure ValueIndex : sig...end eqtype ('a,'b) array val apply : (('a,'b) ?.ValueIndex.index -> 'c) -> ('a,'b) ?.ValueIndex.range -> unit val array : (unit,'1a) BasicArrayIndex.range * '1a -> (unit,'1a) array end [closing foo.sml] val it = () : unit - val x = Arrays.array(100,0); val x = (prim?,100) : (unit,int) Arrays.array - Arrays.Value.Apply (fn a => a) x; std_in:4.1-4.18 Error: unbound variable or constructor in structure: Apply - Arrays.Value.apply (fn a => a) x; val it = () : unit - Arrays.apply (fn a => a) x; std_in:2.1-2.26 Error: operator and operand don't agree (tycon mismatch) operator domain: ('Z,int) ?.ValueIndex.range operand: (unit,int) Arrays.array in expression: Arrays.apply ((fn => )) x - volterra$ Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 410 Title: inlining property not preserved in simple renaming Keywords: Submitter: Andrew Tolmach (apt@cs.princeton.edu) Date: 8/6/91 Version: 0.73 Severity: minor Problem: If I use System.Unsafe.getvar directly, it is inlined, as expected. If I type val g = System.Unsafe.getvar then g does not have access INLINE. Dbm suggests that this is because g is being eta-expanded; I haven't found where this happens in the source. In any case, I don't know why the initial definition of val getvar = InLine.getvar inside the definition of System.Unsafe *does* manage to transfer the inline property... Is it because there's something special about structure InLine? Fix: look for MARKexps around the rhs VALvar. Tolmach: abstract syntax marking. The MARKexps surrounding the RHS of val a = System.Unsafe.getvar prevent the INLINE-ness of getvar being recognized by parse/corelang.sml valbind. If I turn off marking, it works. Tarditi: We should alter parse/corelang.sml valbind so that it recognizes this case specially and properly assigns the INLINE property. Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 411 Title: Runbind Keywords: Submitter: John Reppy (jhr) Date: 8/10/91 Version: 0.71 Problem: Runbind exception Transcript: Standard ML of New Jersey, Version 0.71, 23 July 1991 val it = () : unit - structure A = struct val x = 1 end; structure A : sig val x : int end - structure B = struct structure A = A; val y = 2 end; structure B : sig structure A : sig...end val y : int end - open A; open A - open B; open B - x; uncaught exception Runbind Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 412 Title: Runbind Keywords: Submitter: Dave Tarditi Date: 8/13/91 Version: 0.71 Problem: Code: structure A = struct val x = 5 structure B = struct val y = 5 end end open A.B; structure A = struct end; y; Comments: (Tarditi) There's an incorrect assumption in checkopen, which tests whether any value in a structure which has been rebound is still accessible. Let the old structure be called S and the new environment be N. Let the symbols bound in the environment of S be T. The assumption is that if any symbol A in T is unbound in N, then all other symbols in T are also unbound in N. This is clearly untrue, as the above example shows, where x is unbound in the environment after the redefinition of A but y is not. Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 413 Title: System and IO problems Keywords: Submitter: Emden Gansner Date: 8/16/91 Version: 0.71 Problem: The version of system in the System structure should have type string -> int The execute function in IO is incorrect as written. It passes the the value of environ() to exec, but this is a list of SML strings and exec expects a list of C strings. It should pass (map c_string environ()) instead. Finally, the execute function would be a lot more useful if it allowed a list of arguments as well as program pathname. Status: fixed in 0.74 (JHR) --------------------------------------------------------------------------- Number: 414 Title: getWD wrong Keywords: Submitter : Ian King Date: 8/19/91 Version : 0.66 System : Sun 3/160 , Sun OS 4.1 Severity : Minor Problem : The function getWD in structure System.Directory when called with a unit gives an incoorect result. Code : fun test path = let val cwd = System.Directory.getWD () in { cd_in = fn () => (cd path), cd_out = fn () => (cd cwd) } end Transcipt : val {cd_in,cd_out} = test "directoryname"; val cd_in = fn : unit -> unit val cd_out = fn : unit -> unit cd_in (); val it = () : unit; cd_out (); uncaught exception NotDirectory Comments : This code executes correctly on a Sun Sparc machine. It does not execute correctly on our Sun 3/160. Although I have marked the bug as minor it is irritating because it crashes code which needs to change directories such as loaders. ** This is probably another example of bug #651 (JHR, 10/6/92) ** Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 415 Title: late error detection in parsing Keywords: Submitter: David N. Turner Date: 9/17/91 Version: SML of NJ version 0.73 System: Sun4 Severity: minor Problem: The following incorrect text doesn't generate an error, the secondary prompt appears and the error is only signalled after more text if typed in. Perhaps this is some kind of parser lookahead problem? - if true then 365; (* My input *) = (* nj-sml output *) Owner: Andrew Status: open --------------------------------------------------------------------------- Number: 416 Title: equality property checking in functor parameter matching Keywords: modules, functors, signature matching, equality Submitter: Simon Finn Date: 9/13/91 Version: ? Severity: minor Problem: Try the following simple (?) exercise in semantics, provided by my colleague Mike Crawley: signature PSIG = sig eqtype 'a symTab ; datatype guide = G1 | G2 of guide symTab end; (Q1) Is guide an eqtype? (in PSIG) (A1) Yes, since we require the equality-principal signature. functor PFUN (structure S : sig type 'a symTab end) = struct open S; datatype guide = G1 | G2 of guide symTab; end; (Q2) Is guide an eqtype? (in the output signature of PFUN) (A2) No, because symTab isn't and our signatures must respect equality structure S = struct datatype 'a symTab = Empty end; structure P = PFUN(structure S = S); (Q3) Is guide an eqtype? (in the signature of P) (A3) No, because it wasn't in the functor. Technically, this is because the realisation, \phi, used to instantiate the body of the functor doesn't touch the bound type names contained in the output signature of the functor (except, possibly, for an alpha-conversion). P.G1 = P.G1; (Q4) Is this legal? (A4) No, because P.guide is not an eqtype (see above). functor MFUN(structure X : PSIG) = struct val z = X.G1 = X.G1; end; structure M = MFUN(structure X = P); (Q5) Is this legal? (A5) No, because MFUN demands that guide be an eqtype (see Q1), but P.guide is not an eqtype (see Q3, Q4). Both SMLNJ 0.66 and Poly/ML 1.88 get Q1 - Q4 right but get Q5 wrong. Poly/ML 1.98 gets Q1 - Q5 right. Comment: Conjecture that this is a benign bug. Have not been able to come up with version that is actually wrong. Fix: Could record equality properties inferred in parameter signature instantiation in the signature (memoizing). Test: bug416.sml Owner: dbm Status: open --------------------------------------------------------------------------- Number: 417 Title: cosmetic error message suggestion Keywords: error message Submitter: Andy Koenig Date: 9/12/91 Version: ? Problem: Minor suggestion for SML-NJ: in error messages, how about printing infix functions as infix? Transcript: - 3 + 4.0; std_in:1.1-1.7 Error: operator and operand don't agree (tycon mismatch) operator domain: int * int operand: int * real in expression: + (3,4.0) ^^^^^^^^^ Why not 3+4.0 ?? or at least op+ (3,4.0) Comment: use original code in error message instead of "pretty-printing" abstract syntax Owner: Status: open --------------------------------------------------------------------------- Number: 418 Title: repeated type names in type declarations Keywords: Submitter: Andrzej Filinski Date: 9/11/91 Version: 0.72 System: All Severity: minor (but with potentially serious consequences) Problem: Repeated type names in DATATYPE ... WITHTYPE ... destroy type security. Transcript: Standard ML of New Jersey, Version 0.72, 29 August 1991 val it = () : unit - datatype t = T of int withtype t = string; datatype t con T : int -> t type t = string - T 65:string; val it = "A" : string - Comments: Same problem with ABSTYPE...WITHTYPE. See also bug report 349. Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 419 Title: Runbind Keywords: Submitter: Venkatesh Akella akella@cs.utah.edu Date: 8/27/91 Version: SML of NJ version 0.71 System: Sparc IPC, SunOS Severity: major Problem: Raises an uncaught exception Runbind when a simple CML program running under SML version 0.71 (Version of CML being used is 0.95) The bug can't be reproduced with CML version 0.90 running under SML/NJ 0.66 Code: fun placeBuffer () = let val c = channel () val b = channel () val a = channel () fun input_int (s:string) = fold (fn(a,r) => ord(a) - ord("0") + 10 * r) (tl (rev(explode s))) 0; fun P1 x = (CIO.print( "Waiting for Input on Channel a? \n"); let val y = input_int(CIO.input_line std_in) in s__3 x y end) and s__3 x y = ( ( send (c,y ) ; P1 y )) fun P2 z = (let val v = accept c in s__5 z v end) and s__5 z v = ( (CIO.print (" Output on Channel b!"^Integer.makestring(v)^"\n"); P2 v )) in spawn (fn () => P1 4 ); spawn (fn () => P2 5 ); () end; Transcript: 6 bliss /u/akella/compiler/cml/cml95/cml-0.9.5:: > cml val it = true : bool - System.Directory.cd "/u/akella/compiler/hop/example"; val it = () : unit - use "test_buf.sml"; [opening test_buf.sml] [closing test_buf.sml] uncaught exception Runbind - Comments: The same bug was observed in SML/NJ version 0.66 too but in a different context. I had one integrated environment with SML 0.66, ML-yacc, ML-lex, CML(version 0.9) and my own code. Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 420 Title: uncaught Nth while compiling Keywords: Submitter: Tsung-Min Kuo kuo@ecrc.de Date: 9/19/91 Version: Version 0.66, 15 September 1990 System: SPARCstation 1, SUNOS 4.0 Severity: sever Problem: Compiler-generated exception : uncaught exception Nth Code: signature EXCHANGE_STRUCTURE = sig type tree val new_node : tree -> tree end structure ex : EXCHANGE_STRUCTURE = struct datatype tree = Subwindow of subwindow | Canvas of canvas | Frame of frame | Baseframe of baseframe | NULL withtype subwindow = {t_node: tree} and canvas = {subwindow: subwindow} and frame = {tree_node: tree} and baseframe = {frame: frame,foog:bool} exception Tube_Bug fun position (Canvas c) = position(Subwindow(#subwindow c)) | position (Baseframe bf) = position(Frame (#frame bf)) | position _ = raise Tube_Bug fun tn_set_position(t,p) = () fun set_position (Subwindow sb) = tn_set_position(#t_node sb,0) | set_position (Frame f) = tn_set_position(#tree_node f,0) | set_position (Canvas c) = set_position(Subwindow(#subwindow c)) | set_position (Baseframe bf) = set_position(Frame(#frame bf)) | set_position _ = raise Tube_Bug fun components(Canvas c) = components(Subwindow (#subwindow c)) | components(Baseframe bf) = components(Frame (#frame bf)) | components _ = raise Tube_Bug fun bounding_box(Canvas c) = bounding_box(Subwindow (#subwindow c)) | bounding_box(Baseframe bf) = bounding_box(Frame (#frame bf)) | bounding_box _ = raise Tube_Bug fun tn_set_bounding_box(t,r) = () fun set_bounding_box(Subwindow sb) = tn_set_bounding_box(#t_node sb,0) | set_bounding_box(Frame f) = tn_set_bounding_box(#tree_node f,0) | set_bounding_box(Canvas c) = set_bounding_box(Subwindow(#subwindow c)) | set_bounding_box(Baseframe bf) = set_bounding_box(Frame(#frame bf)) | set_bounding_box _ = raise Tube_Bug fun new_node tl = let val pos = position(Frame {tree_node = tl}) in NULL end end Transcript: - use "bug"; [opening bug] [closing bug] uncaught exception Nth - Comments: The enclosed code is a trimmed version of a big program, got in an attempt to isolate the error. As you can see, this program virtually does nothing and is full of redundancy. But whatever I did to try to cut it down, results in a good program happily accepted by compiler. Here are some of the things I have tried : * not use the signature constraint on the structure * delete any of the redundant function definitions, e.g."components" * remove the redundant call to function "position" in "new_node" * or, even call "position" with argument NULL * remove a clause from any function definition(I tried many of them) * flat the record, e.g. make type frame = tree * remove the boolean field in type "baseframe" * get rid of second argument of functions "tn_set_position" and "tn_set_bounding_box" * replace equal by equal, e.g. replace calls to "tn_set_position" by () * replace recursive call by direct call, e.g. in "Canvas" clause of function "set_position" Conclusion: These are so diverse that I can not even guess any. Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 421 Title: getWD under SPARC/Mach (same as 353) Keywords: Submitter: Fritz Knabe Date: 9/18/91 Version: 0.73 System: SPARC/Mach (CMU) Severity: minor Problem: System.Directory.getWD () is still broken for me in version 73 on a Sparc. It raises a SystemCall exception. Transcript: (c/o Gene Rollins, 8/21/92) Standard ML of New Jersey, Version 0.88, August 14, 1992 with SourceGroup 2.2 built on Mon Aug 17 23:23:16 EDT 1992 - fun pwd() = System.system "pwd"; val pwd = fn : unit -> int - fun cd x = (System.Directory.cd x; pwd()) handle any => (pwd(); raise any); val cd = fn : string -> int - fun ll () = System.system "ls -lL"; val ll = fn : unit -> int - fun mkdir x = System.system ("mkdir " ^ x); val mkdir = fn : string -> int - pwd(); /usr0/rollins val it = 0 : int - ll(); total 0 val it = 0 : int - mkdir "src"; val it = 0 : int - mkdir "bin"; val it = 0 : int - ll(); total 2 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:16 src val it = 0 : int - cd "src"; /usr0/rollins/src val it = 0 : int - cd "../bin"; /usr0/rollins/bin val it = 0 : int - cd "../src"; /usr0/rollins/src val it = 0 : int - cd ".."; /usr0/rollins val it = 0 : int - cd "bin"; /usr0/rollins/bin val it = 0 : int - cd ".."; /usr0/rollins val it = 0 : int - ll(); total 2 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:16 src val it = 0 : int - mkdir "tools"; val it = 0 : int - cd "src"; /usr0/rollins/src val it = 0 : int - cd "../tools"; /usr0/rollins/src uncaught exception NotDirectory - cd "../bin"; /usr0/rollins/bin val it = 0 : int - cd "../tools"; /usr0/rollins/bin uncaught exception NotDirectory (* the rest is more of the same *) - cd ".."; /usr0/rollins val it = 0 : int - cd "tools"; /usr0/rollins/tools val it = 0 : int - cd "../src"; /usr0/rollins/src val it = 0 : int - cd "../tools"; /usr0/rollins/src uncaught exception NotDirectory - cd ".."; /usr0/rollins val it = 0 : int - ll(); total 3 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools val it = 0 : int - mkdir "mo.mipsl"; val it = 0 : int - ll(); total 4 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools val it = 0 : int - cd "mo.mipsl"; /usr0/rollins uncaught exception NotDirectory - cd "src"; /usr0/rollins/src val it = 0 : int - cd "../mo.mipsl"; /usr0/rollins/mo.mipsl val it = 0 : int - cd "../tools"; /usr0/rollins/mo.mipsl uncaught exception NotDirectory - cd "../bin"; /usr0/rollins/bin val it = 0 : int - cd "../mo.mipsl"; /usr0/rollins/mo.mipsl val it = 0 : int - cd ".."; /usr0/rollins val it = 0 : int - cd "mo.mipsl"; /usr0/rollins uncaught exception NotDirectory - ll(); total 4 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools val it = 0 : int - mkdir "zed"; val it = 0 : int - ll(); total 5 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - cd "zed"; /usr0/rollins/zed val it = 0 : int - cd "../tools"; /usr0/rollins/zed uncaught exception NotDirectory - cd "../src"; /usr0/rollins/src val it = 0 : int - cd "../zed"; /usr0/rollins/zed val it = 0 : int - cd ".."; /usr0/rollins val it = 0 : int - mkdir "moon"; val it = 0 : int - cd "moon"; /usr0/rollins uncaught exception NotDirectory - cd "src"; /usr0/rollins/src val it = 0 : int - cd "../moon"; /usr0/rollins/moon val it = 0 : int - cd ".."; /usr0/rollins val it = 0 : int - ll(); total 6 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:24 moon drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - mkdir "tooth"; val it = 0 : int - ll(); total 7 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:24 moon drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:25 tooth drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - cd "tooth"; /usr0/rollins/tooth val it = 0 : int - cd "../src"; /usr0/rollins/src val it = 0 : int - cd "../tooth"; /usr0/rollins/src uncaught exception NotDirectory - cd ".."; /usr0/rollins val it = 0 : int - ll(); total 7 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:24 moon drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:25 tooth drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - cd "mzz"; /usr0/rollins uncaught exception NotDirectory - mkdir "mzz"; val it = 0 : int - cd "mzz"; /usr0/rollins/mzz val it = 0 : int - cd "../src"; /usr0/rollins/src val it = 0 : int - cd "../mzz"; /usr0/rollins/mzz val it = 0 : int - mkdir "me"; val it = 0 : int - ll(); total 1 drwxr-xr-x 2 rollins 512 Aug 20 12:26 me val it = 0 : int - pwd(); /usr0/rollins/mzz val it = 0 : int - cd ".."; /usr0/rollins val it = 0 : int - mkdir "me"; val it = 0 : int - ll(); total 9 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:26 me drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:24 moon drwxr-xr-x 3 rollins 512 Aug 20 12:26 mzz drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:25 tooth drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - cd "me"; /usr0/rollins/me val it = 0 : int - cd "../tooth"; /usr0/rollins/me uncaught exception NotDirectory - cd ".."; /usr0/rollins val it = 0 : int - mkdir "teeth"; val it = 0 : int - cd "teeth"; /usr0/rollins/teeth val it = 0 : int - cd "../src"; /usr0/rollins/src val it = 0 : int - cd "../teeth"; /usr0/rollins/src uncaught exception NotDirectory - cd ".."; /usr0/rollins val it = 0 : int - ll(); total 10 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:26 me drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:24 moon drwxr-xr-x 3 rollins 512 Aug 20 12:26 mzz drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:27 teeth drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:25 tooth drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - mkdir "tzz"; val it = 0 : int - ll(); total 11 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:26 me drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:24 moon drwxr-xr-x 3 rollins 512 Aug 20 12:26 mzz drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:27 teeth drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:25 tooth drwxr-xr-x 2 rollins 512 Aug 20 12:27 tzz drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - cd "tzz"; /usr0/rollins/tzz val it = 0 : int - cd "../src"; /usr0/rollins/src val it = 0 : int - cd "../tzz"; /usr0/rollins/tzz val it = 0 : int - cd "../teeth"; /usr0/rollins/tzz uncaught exception NotDirectory - cd ".."; /usr0/rollins val it = 0 : int - ll(); total 11 drwxr-xr-x 2 rollins 512 Aug 20 12:16 bin drwxr-xr-x 2 rollins 512 Aug 20 12:26 me drwxr-xr-x 2 rollins 512 Aug 20 12:18 mo.mipsl drwxr-xr-x 2 rollins 512 Aug 20 12:24 moon drwxr-xr-x 3 rollins 512 Aug 20 12:26 mzz drwxr-xr-x 2 rollins 512 Aug 20 12:16 src drwxr-xr-x 2 rollins 512 Aug 20 12:27 teeth drwxr-xr-x 2 rollins 512 Aug 20 12:17 tools drwxr-xr-x 2 rollins 512 Aug 20 12:25 tooth drwxr-xr-x 2 rollins 512 Aug 20 12:27 tzz drwxr-xr-x 2 rollins 512 Aug 20 12:23 zed val it = 0 : int - Comment: (Lal George) There is an operating system level 3 call that can be used to get the working directory. Unfortunately, we cannot use this because it does a malloc. So we have to build up the working directory pathname by interpreting inodes. It is my guess that this is what bombs out in the Andrew file system. ** This is probably another example of bug #651 (JHR, 10/6/92) ** Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 422 Title: overflow on int to real conversion Keywords: Submitter: Andrzej Filinski Date: 9/20/91 Version: 0.73 System: all Severity: major Problem: int->real conversion overflows on MININT Transcript: Standard ML of New Jersey, Version 0.73, 10 September 1991 Arrays have changed; see doc/NEWS val it = () : unit - ~0x40000000; val it = ~1073741824 : int - real it; uncaught exception Overflow - Fix: In boot/perv.sml, move redundant check for MININT from Integer.mod to Real.real :-). Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 423 Title: printing of structure signatures Keywords: Submitter: John Reppy Date: 10/1/91 Version: 0.73 Severity: minor Problem: At top level, some structure signatures are printed as identifiers, while others are printed in full. Transcript: Standard ML of New Jersey, Version 0.73, 10 September 1991 Arrays have changed; see doc/NEWS val it = () : unit - structure I = IO; structure I : IO - structure V = Vector; structure V : sig eqtype 'a vector exception Size exception Subscript val length : 'a vector -> int val sub : 'a vector * int -> 'a val tabulate : int * (int -> 'a) -> 'a vector val vector : 'a list -> 'a vector val vector_n : int * 'a list -> 'a vector end - Comments: [Dave Tarditi] The reported behavior is intentional: the basic idea is that if we know the name of a structure's signature, we print the name of the signature instead of the whole signature. More formally, if S is structure which is bound to structure id SX, and S was the result of doing a signature match against signature T, which itself is bound to signature identifier TX, then when we print the signature for the structure bound to SX, we will print TX, provided that TX is still bound to the same signature. Thus we get the following results at the top-level: - structure S = IO; structure S : IO - structure T = S; structure T : IO but when we re-bind the signature identifier IO we get: - signature IO = sig end; signature IO = sig end - structure S = IO structure S = sig type instream ... end The problem is that the signature identifier VECTOR is not in the top-level environment. To fix this, change build/process.sml, lines 202-204 from: map Symbol.sigSymbol ["REF","LIST","ARRAY","BYTEARRAY","IO","BOOL", "ENVIRON", "COMPILE", "STRING","INTEGER","REAL","GENERAL"] to: map Symbol.sigSymbol ["REF","LIST","ARRAY","BYTEARRAY","IO","BOOL", "ENVIRON", "COMPILE" "STRING","INTEGER","REAL","GENERAL", "VECTOR"] Maybe we should add a flag to toggle this behavior, but I was hoping that we would an environment browsing structure to the compiler instead. It's a kludge to have to type "structure S = S" to see the signature of S. Status: not a bug (but a feature!) --------------------------------------------------------------------------- Number: 424 Title: IO.execute on SPARC Keywords: Submitter: Emden Gansner Date: 10/1/91 Version: 0.73 System: SPARC, SunOS 4.1 Severity: moderate Problem: "I just noticed that, starting with 0.71, the IO.execute function causes problems on the sparc, running SunOS4.1. This problem doesn't occur on 0.73 running on hunny." Transcript: t) /usr/addon/sml/bin/*69* Standard ML of New Jersey, Version 0.69, 3 April 1991 val it = () : unit - IO.execute "/bin/date"; val it = (-,-) : instream * outstream - t) t) sml Standard ML of New Jersey, Version 0.71, 23 July 1991 val it = () : unit - IO.execute "/bin/date"; /home/erg/bin/sml[7]: 6446 Bus error t) sml73 Standard ML of New Jersey, Version 0.73, 10 September 1991 val it = () : unit - IO.execute "/bin/date"; Bus error t) Status: fixed in 0.74 (JHR) --------------------------------------------------------------------------- Number: 425 Title: profiler flakiness Keywords: Submitter: Frank Pfenning Date: 10/2/91 Version: 0.73 Problem: I am currently in the process of eliminating obvious inefficiencies in an ML implementation of a logic programming language. While using the profiler, I noticed that it seemed to lead to inordinately large core images during the development (there is also a small overhead for the mere fact that we are profiling, but that is acceptable). My guess is the profiler keeps a (non-weak) pointer to code somehow, which prevents it from being garbage collected even if it is no longer accessible from the top-level. The fact that redefined functions show up twice or more often in the profiling statistics seem to confirm that, but I may be using it wrong, or there could be other reasons. I would be interested to hear what the developer/implementor of the profiler has to say about this. Thanks, Comment: (Andrew Appel) Yes, I think your analysis is correct. There's a profiler function that resets the profiler; perhaps that's what you want. But if you use it, you'd have to reload your entire source code. Status: fixed in 0.86 --------------------------------------------------------------------------- Number: 426 Title: type printing Keywords: Submitter: Andy Koenig (europa!ark) Date: 10/4/91 Version: 0.73 Severity: minor Problem: Spurious parenthesis around unit. Transcript: - (3,()); val it = (3,()) : int * (unit) Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 427 Title: Compiler bug: defineEqTycon/eqtyc Keywords: Submitter: John Reppy Date: 10/6/91 Version: 0.73 Severity: ? Problem: Compiler bug: defineEqTycon/eqtyc -- bad tycon Transcript: Standard ML of New Jersey, Version 0.73, 10 September 1991 Arrays have changed; see doc/NEWS val it = () : unit - datatype 'a array = ARRAY of 'a ref VECTOR; std_in:2.38-2.43 Error: unbound type constructor VECTOR Error: Compiler bug: defineEqTycon/eqtyc -- bad tycon Comments: Obviously this code is incorrect, but I have a bigger example that only prints out the "bad tycon" message. Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 428 Title: openStructureVar -- bad access value Keywords: Submitter: Benjamin.Pierce@cs.cmu.edu Date: 4/3/91 Version: 0.67 (with SourceGroup) System: SunOS 4.1 Severity: Major Problem: Compiler bug: EnvAccess.openStructureVar -- bad access value Code: see below Transcript: Standard ML of New Jersey, Version 0.67, 21 November 1990 (Built on Sun Mar 17 11:37:30 EST 1991 with GnuTags and SourceGroup) val it = () : unit - use "bad.tmp"; [opening bad.tmp] signature WR = sig type Wr val close : Wr -> unit val extract_str : Wr -> string val to_file : string -> Wr val to_fn : (string -> unit) -> (unit -> unit) -> Wr val to_nowhere : unit -> Wr val to_stdout : unit -> Wr val to_string : unit -> Wr val to_wrs : Wr list -> Wr val write_wr : Wr -> string -> unit end signature PP = sig structure Wr : sig...end type Pp val DEBUG : bool ref val break : Pp -> bool -> int -> unit val endb : Pp -> unit val expbreak : Pp -> bool -> string -> unit val pp_from_wr : Wr.Wr -> Pp val pwrite : Pp -> string -> unit val set_margin : Pp -> int -> unit val setb : Pp -> unit val wr_from_pp : Pp -> Wr.Wr end signature WRMGT = sig structure Pp : sig...end structure Wr : sig...end val get_current_wr : unit -> Wr.Wr val set_current_wr : Wr.Wr -> unit val stdpp : unit -> Pp.Pp val write : string -> unit end signature STRINGUTILS = sig end signature REGISTRY = sig type registeredtype val register : string -> (registeredtype -> unit) -> unit val registerflag : string -> registeredtype ref -> unit val set_all : registeredtype -> unit val set_flag : string -> registeredtype -> unit end signature LISTUTILS = sig val filter : ('a -> bool) -> 'a list -> 'a list val forall : ('a -> bool) -> 'a list -> bool val forsome : ('a -> bool) -> 'a list -> bool val mapappend : ('a -> 'b list) -> 'a list -> 'b list val mapfold : ('a -> 'b) -> ('b -> 'b -> 'b) -> 'b -> 'a list -> 'b val mapunit : ('b -> 'a) -> 'b list -> unit val mapunit_tuple : ('a -> unit) -> (unit -> unit) -> 'a list -> unit val memq : ('a -> 'a -> bool) -> 'a list -> 'a -> bool end signature ID = sig type T val == : T -> T -> bool val hashcode : T -> int val intern : string -> T val new : unit -> T val new_from : T -> T val tostr : T -> string end signature DEBUGUTILS = sig val wrap : bool ref -> string -> (unit -> 'a) -> (unit -> unit) -> ('a -> unit) -> 'a end signature GLOBALS = sig structure Id : sig...end structure Pp : sig...end structure Pp : sig...end structure Wr : sig...end structure Wr : sig...end structure WrMgt : sig...end type registeredtype val filter : ('a -> bool) -> 'a list -> 'a list val forall : ('a -> bool) -> 'a list -> bool val forsome : ('a -> bool) -> 'a list -> bool val get_current_wr : unit -> Wr.Wr val mapappend : ('a -> 'b list) -> 'a list -> 'b list val mapfold : ('a -> 'b) -> ('b -> 'b -> 'b) -> 'b -> 'a list -> 'b val mapunit : ('b -> 'a) -> 'b list -> unit val mapunit_tuple : ('a -> unit) -> (unit -> unit) -> 'a list -> unit val memq : ('a -> 'a -> bool) -> 'a list -> 'a -> bool val register : string -> (registeredtype -> unit) -> unit val registerflag : string -> registeredtype ref -> unit val set_all : registeredtype -> unit val set_current_wr : Wr.Wr -> unit val set_flag : string -> registeredtype -> unit val stdpp : unit -> Pp.Pp val wrap : bool ref -> string -> (unit -> 'a) -> (unit -> unit) -> ('a -> unit) -> 'a val write : string -> unit end Error: Compiler bug: EnvAccess.openStructureVar -- bad access value [closing bad.tmp] - -------------------------------------------------------------------------- (* And here's the offending file ... *) signature WR = sig type Wr val to_stdout: unit -> Wr val to_file: string -> Wr val to_nowhere: unit -> Wr val to_wrs: Wr list -> Wr val to_fn: (string->unit) -> (unit->unit) -> Wr val to_string: unit -> Wr val extract_str: Wr -> string val close: Wr -> unit val write_wr: Wr -> string -> unit end; signature PP = sig structure Wr: WR type Pp val pp_from_wr: Wr.Wr -> Pp val wr_from_pp: Pp -> Wr.Wr; val pwrite : Pp -> string -> unit val setb: Pp -> unit val endb: Pp -> unit val break: Pp -> bool -> int -> unit val expbreak: Pp -> bool -> string -> unit val set_margin: Pp -> int -> unit val DEBUG: bool ref end; signature WRMGT = sig (* Maintains a notion of a current (prettyprinting) writer and its associated prettyprinter *) structure Wr: WR; structure Pp: PP; sharing Pp.Wr = Wr; val set_current_wr: Wr.Wr -> unit; val get_current_wr: unit -> Wr.Wr; val stdpp: unit -> Pp.Pp; val write: string -> unit; end; signature STRINGUTILS = sig end; signature REGISTRY = sig type registeredtype val register: string -> (registeredtype->unit) -> unit val registerflag: string -> (registeredtype ref) -> unit val set_flag: string -> registeredtype -> unit val set_all: registeredtype -> unit end; signature LISTUTILS = sig val memq: ('a -> 'a -> bool) -> 'a list -> 'a -> bool val mapappend: ('a -> 'b list) -> ('a list) -> ('b list) val mapunit: ('a -> 'b) -> ('a list) -> unit val mapunit_tuple: ('a -> unit) -> (unit -> unit) -> ('a list) -> unit val mapfold: ('a -> 'b) -> ('b -> 'b -> 'b) -> 'b -> ('a list) -> 'b val forall: ('a -> bool) -> ('a list) -> bool val forsome: ('a -> bool) -> ('a list) -> bool val filter: ('a -> bool) -> ('a list) -> ('a list) end; signature ID = sig type T val intern: string -> T val tostr: T -> string val hashcode: T -> int val new: unit -> T val new_from: T -> T val == : T -> T -> bool end; (* May eventually want to support these too: val lexlt : T -> T -> bool *) signature DEBUGUTILS = sig val wrap: (bool ref) -> string -> (unit -> 'a) -> (unit -> unit) -> ('a -> unit) -> 'a end; signature GLOBALS = sig structure Wr: WR structure Pp: PP structure WrMgt: WRMGT structure Id: ID sharing Pp.Wr = Wr sharing WrMgt.Pp = Pp include WRMGT include LISTUTILS include STRINGUTILS include DEBUGUTILS include REGISTRY sharing type registeredtype = bool end; signature TYPPVT = sig structure Globals: GLOBALS open Globals datatype pretyp = PRETVAR of Id.T | PREARROW of pretyp * pretyp | PREALL of Id.T * pretyp * pretyp | PREMEET of pretyp list datatype T = TVAR of unit * int | ARROW of unit * T * T | ALL of {name:Id.T} * T * T | MEET of unit * (T list) datatype tenvelt = BND of Id.T * T | ABB of Id.T * T | VBND of Id.T * T datatype tenv = TENV of tenvelt list val empty_tenv: tenv val extend_bound: tenv -> Id.T -> T -> tenv val push_bound: tenv -> Id.T -> T -> tenv val extend_abbrev: tenv -> Id.T -> T -> tenv val push_abbrev: tenv -> Id.T -> T -> tenv val extend_binding: tenv -> Id.T -> T -> tenv val push_binding: tenv -> Id.T -> T -> tenv val pop: tenv -> tenv val index: tenv -> Id.T -> int val lookup_name: tenv -> int -> Id.T val lookup_and_relocate_bound: tenv -> int -> T val lookup_and_relocate_binding: tenv -> int -> T val lookup_and_relocate: tenv -> int -> tenvelt val lookup: tenv -> int -> tenvelt val relocate: int -> T -> T exception UnknownId of string exception WrongKindOfId of tenv * int * string val debruijnify: tenv -> pretyp -> T val prt: Pp.Pp -> tenv -> T -> unit val prt_tenv: Pp.Pp -> tenv -> unit val NS: T end; Status: fixed in 0.71 --------------------------------------------------------------------------- Number: 429 Title: signature match fails Keywords: Submitter: Benjamin Pierce Date: 4/4/91 Version: 0.69 Problem: signature spec not matched when it should be Transcript: Standard ML of New Jersey, Version 0.69, 3 April 1991 val it = () : unit - use "bug.tmp"; use "bug.tmp"; [opening bug.tmp] [Major collection... [Increasing heap to 10011k] 96% used (3502604/3627780), 7260 msec] [Increasing heap to 10431k] bug.tmp:1545.8-1775.3 Error: value type in structure doesn't match signature spec name: prt spec: Pp -> tenv -> T -> unit actual: ?.Pp -> tenv -> T -> unit bug.tmp:1545.8-1775.3 Error: value type in structure doesn't match signature spec name: prt_tenv spec: Pp -> tenv -> unit actual: ?.Pp -> tenv -> unit bug.tmp:1798.7-1802.44 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: Typ.prt pp bug.tmp:1798.7-1820.56 Error: rules don't agree (tycon mismatch) expected: ?.Pp * 'Z * 'Y list * 'X * rhs_flag -> unit found: ?.Pp * tenv * lhsqueue list * 'W * 'V -> 'U rule: (pp,te,:: (ARROW_LHS ,nil),t2,flag) => ( te t1;# # t2 flag) bug.tmp:1807.7-1809.38 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: Pp.pwrite pp bug.tmp:1798.7-1820.56 Error: rules don't agree (tycon mismatch) expected: ?.Pp * 'Z * 'Y list * 'X * rhs_flag -> unit found: ?.Pp * tenv * lhsqueue list * 'W * 'V -> 'U rule: (pp,te,:: (ARROW_LHS ,X2),t2,flag) => ( te t1;Pp.pwrite pp ",";# # t2 flag) bug.tmp:1811.7-1814.56 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: Typ.prt pp bug.tmp:1811.7-1814.56 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: describe_rest pp bug.tmp:1816.7-1820.56 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: Typ.prt pp bug.tmp:1816.7-1820.56 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: describe_rest pp bug.tmp:1797.1-1820.56 Error: pattern and expression in val rec dec don't agree (tycon mismatch) pattern: ?.Pp -> tenv -> lhsqueue list -> 'Z -> 'Y -> 'X expression: ?.Pp -> tenv -> lhsqueue list -> 'W -> rhs_flag -> unit in declaration: describe_rest = (fn arg => (fn => )) bug.tmp:1823.3-1829.14 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: Typ.prt pp bug.tmp:1823.3-1829.14 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: describe_rest pp bug.tmp:1874.15-1874.54 Error: operator and operand don't agree (tycon mismatch) operator domain: ?.Pp operand: ?.Pp in expression: describe_problem (stdpp ()) [closing bug.tmp] -------------------------------------------------------------------------- (* and here's the offending file... Sorry it's a bit long *) signature WR = sig type Wr val to_stdout: unit -> Wr val to_file: string -> Wr val to_nowhere: unit -> Wr val to_wrs: Wr list -> Wr val to_fn: (string->unit) -> (unit->unit) -> Wr val to_string: unit -> Wr val extract_str: Wr -> string val close: Wr -> unit val write_wr: Wr -> string -> unit end signature PP = sig structure Wr: WR type Pp val pp_from_wr: Wr.Wr -> Pp val wr_from_pp: Pp -> Wr.Wr; val pwrite : Pp -> string -> unit val setb: Pp -> unit val endb: Pp -> unit val break: Pp -> bool -> int -> unit val expbreak: Pp -> bool -> string -> unit val set_margin: Pp -> int -> unit val DEBUG: bool ref end signature WRMGT = sig (* Maintains a notion of a current (prettyprinting) writer and its associated prettyprinter *) structure Wr: WR; structure Pp: PP; sharing Pp.Wr = Wr; val set_current_wr: Wr.Wr -> unit; val get_current_wr: unit -> Wr.Wr; val stdpp: unit -> Pp.Pp; val write: string -> unit; end signature STRINGUTILS = sig end signature REGISTRY = sig type registeredtype val register: string -> (registeredtype->unit) -> unit val registerflag: string -> (registeredtype ref) -> unit val set_flag: string -> registeredtype -> unit val set_all: registeredtype -> unit end signature LISTUTILS = sig val memq: ('a -> 'a -> bool) -> 'a list -> 'a -> bool val mapappend: ('a -> 'b list) -> ('a list) -> ('b list) val mapunit: ('a -> 'b) -> ('a list) -> unit val mapunit_tuple: ('a -> unit) -> (unit -> unit) -> ('a list) -> unit val mapfold: ('a -> 'b) -> ('b -> 'b -> 'b) -> 'b -> ('a list) -> 'b val forall: ('a -> bool) -> ('a list) -> bool val forsome: ('a -> bool) -> ('a list) -> bool val filter: ('a -> bool) -> ('a list) -> ('a list) end signature ID = sig type T val intern: string -> T val tostr: T -> string val hashcode: T -> int val new: unit -> T val new_from: T -> T val == : T -> T -> bool end (* May eventually want to support these too: val lexlt : T -> T -> bool *) signature DEBUGUTILS = sig val wrap: (bool ref) -> string -> (unit -> 'a) -> (unit -> unit) -> ('a -> unit) -> 'a end signature GLOBALS = sig structure Wr: WR structure Pp: PP structure WrMgt: WRMGT structure Id: ID sharing Pp.Wr = Wr sharing WrMgt.Pp = Pp include WRMGT include LISTUTILS include STRINGUTILS include DEBUGUTILS include REGISTRY sharing type registeredtype = bool exception CantHappen end signature TYPPVT = sig structure Globals: GLOBALS open Globals datatype pretyp = PRETVAR of Id.T | PREARROW of pretyp * pretyp | PREALL of Id.T * pretyp * pretyp | PREMEET of pretyp list datatype T = TVAR of unit * int | ARROW of unit * T * T | ALL of {name:Id.T} * T * T | MEET of unit * (T list) datatype tenvelt = BND of Id.T * T | ABB of Id.T * T | VBND of Id.T * T datatype tenv = TENV of tenvelt list val empty_tenv: tenv val push_bound: tenv -> Id.T -> T -> tenv val push_abbrev: tenv -> Id.T -> T -> tenv val push_binding: tenv -> Id.T -> T -> tenv val pop: tenv -> tenv val index: tenv -> Id.T -> int val lookup_name: tenv -> int -> Id.T val lookup_and_relocate_bound: tenv -> int -> T val lookup_and_relocate_binding: tenv -> int -> T val lookup_and_relocate: tenv -> int -> tenvelt val lookup: tenv -> int -> tenvelt val relocate: int -> T -> T (* Substitute the first arg for instances of var #0 in the second arg *) val tsubst_top: T -> T -> T exception UnknownId of string exception WrongKindOfId of tenv * int * string val debruijnify: tenv -> pretyp -> T val prt: Pp.Pp -> tenv -> T -> unit val prt_tenv: Pp.Pp -> tenv -> unit val NS: T end signature LEQ = sig structure Typ: TYPPVT structure Globals: GLOBALS sharing Globals = Typ.Globals val leq: Typ.tenv -> Typ.T -> Typ.T -> bool end signature LR_TABLE = sig datatype state = STATE of int datatype term = T of int datatype nonterm = NT of int datatype action = SHIFT of state | REDUCE of int | ACCEPT | ERROR type table val numStates : table -> int val describeActions : table -> state -> ((term * action) list) * action val describeGoto : table -> state -> (nonterm * state) list 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) list) * action) list, gotos : (nonterm * state) list list, numStates : int, initialState : state} -> table end signature TOKEN = sig structure LrTable : LR_TABLE datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b) val sameToken : ('a,'b) token * ('a,'b) token -> bool end signature PARSER_DATA = sig (* the type of line numbers *) type pos (* the type of semantic values *) type svalue (* the type of the user-supplied argument to the parser *) type arg (* the intended type of the result of the parser. This value is produced by applying extract from the structure Actions to the final semantic value resultiing from a parse. *) type result structure LrTable : LR_TABLE structure Token : TOKEN sharing Token.LrTable = LrTable (* structure Actions contains the functions which mantain the semantic values stack in the parser. Void is used to provide a default value for the semantic stack. *) structure Actions : sig val actions : int * pos * (LrTable.state * (svalue * pos * pos)) list * arg-> LrTable.nonterm * (svalue * pos * pos) * ((LrTable.state *(svalue * pos * pos)) list) val void : svalue val extract : svalue -> result end (* structure EC contains information used to improve error recovery in an error-correcting parser *) structure EC : sig val is_keyword : LrTable.term -> bool val noShift : LrTable.term -> bool val preferred_subst : LrTable.term -> LrTable.term list val preferred_insert : LrTable.term -> bool 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 FMEET_TOKENS = sig type ('a,'b) token type svalue val T_PACK: ('a * 'a) ->(svalue,'a) token val T_END: ('a * 'a) ->(svalue,'a) token val T_OPEN: ('a * 'a) ->(svalue,'a) token val T_SOME: ('a * 'a) ->(svalue,'a) token val T_INSTALL: ('a * 'a) ->(svalue,'a) token val T_OBSERVE: ('a * 'a) ->(svalue,'a) token val T_FOR: ('a * 'a) ->(svalue,'a) token val T_OF: ('a * 'a) ->(svalue,'a) token val T_CASE: ('a * 'a) ->(svalue,'a) token val T_NS: ('a * 'a) ->(svalue,'a) token val T_IN: ('a * 'a) ->(svalue,'a) token val T_ALL: ('a * 'a) ->(svalue,'a) token val T_WITH: ('a * 'a) ->(svalue,'a) token val T_CHECK: ('a * 'a) ->(svalue,'a) token val T_DEBUG: ('a * 'a) ->(svalue,'a) token val T_RESET: ('a * 'a) ->(svalue,'a) token val T_SET: ('a * 'a) ->(svalue,'a) token val T_TYPE: ('a * 'a) ->(svalue,'a) token val T_USE: ('a * 'a) ->(svalue,'a) token val T_STR_CONST: ((string) * 'a * 'a) ->(svalue,'a) token val T_INT_CONST: ((string) * 'a * 'a) ->(svalue,'a) token val T_ID: ((string) * 'a * 'a) ->(svalue,'a) token val T_BIGLAMBDA: ('a * 'a) ->(svalue,'a) token val T_LAMBDA: ('a * 'a) ->(svalue,'a) token val T_INTER: ('a * 'a) ->(svalue,'a) token val T_RCURLY: ('a * 'a) ->(svalue,'a) token val T_LCURLY: ('a * 'a) ->(svalue,'a) token val T_RANGLE: ('a * 'a) ->(svalue,'a) token val T_LANGLE: ('a * 'a) ->(svalue,'a) token val T_RBRACK: ('a * 'a) ->(svalue,'a) token val T_LBRACK: ('a * 'a) ->(svalue,'a) token val T_RPAREN: ('a * 'a) ->(svalue,'a) token val T_LPAREN: ('a * 'a) ->(svalue,'a) token val T_DARROW: ('a * 'a) ->(svalue,'a) token val T_ARROW: ('a * 'a) ->(svalue,'a) token val T_AT: ('a * 'a) ->(svalue,'a) token val T_DOLLAR: ('a * 'a) ->(svalue,'a) token val T_DOUBLEEQ: ('a * 'a) ->(svalue,'a) token val T_EQ: ('a * 'a) ->(svalue,'a) token val T_APOST: ('a * 'a) ->(svalue,'a) token val T_COMMA: ('a * 'a) ->(svalue,'a) token val T_LEQ: ('a * 'a) ->(svalue,'a) token val T_SEMICOLON: ('a * 'a) ->(svalue,'a) token val T_COLON: ('a * 'a) ->(svalue,'a) token val T_DOT: ('a * 'a) ->(svalue,'a) token val T_EOF: ('a * 'a) ->(svalue,'a) token end signature FMEET_LRVALS = sig structure Tokens : FMEET_TOKENS structure ParserData:PARSER_DATA sharing type ParserData.Token.token = Tokens.token sharing type ParserData.svalue = Tokens.svalue end (* Externally visible aspects of the lexer and parser *) signature INTERFACE = sig type pos val line : pos ref val init_line : unit -> unit val next_line : unit -> unit val error : string * pos * pos -> unit end (* signature INTERFACE *) signature TYP = sig structure Globals: GLOBALS open Globals datatype pretyp = PRETVAR of Id.T | PREARROW of pretyp * pretyp | PREALL of Id.T * pretyp * pretyp | PREMEET of pretyp list type T type tenv val empty_tenv: tenv val push_bound: tenv -> Id.T -> T -> tenv val push_abbrev: tenv -> Id.T -> T -> tenv val push_binding: tenv -> Id.T -> T -> tenv val pop: tenv -> tenv exception UnknownId of string exception WrongKindOfId of tenv * int * string val debruijnify: tenv -> pretyp -> T val prt: Pp.Pp -> tenv -> T -> unit val prt_tenv: Pp.Pp -> tenv -> unit val NS: T end signature TRM = sig structure Globals: GLOBALS structure Typ: TYP sharing Typ.Globals = Globals open Globals datatype pretrm = PREVAR of Id.T | PREABS of Id.T * Typ.pretyp * pretrm | PREAPP of pretrm * pretrm | PRETABS of Id.T * Typ.pretyp * pretrm | PRETAPP of pretrm * Typ.pretyp | PREFOR of Id.T * (Typ.pretyp list) * pretrm type T exception UnknownId of string val debruijnify: Typ.tenv -> pretrm -> T val prt: Pp.Pp -> Typ.tenv -> T -> unit end signature PARSERES = sig structure Typ : TYP structure Trm : TRM structure Globals: GLOBALS sharing Typ.Globals = Globals sharing Trm.Typ = Typ datatype T = Leq of Typ.pretyp * Typ.pretyp | Type_Assumption of Globals.Id.T * Typ.pretyp | Type_Abbrev of Globals.Id.T * Typ.pretyp | Term_Def of Globals.Id.T * Trm.pretrm | Term_Assumption of Globals.Id.T * Typ.pretyp | Use of string | Set of string * string | Nothing end signature PARSE = sig structure ParseRes : PARSERES val file_parse: string -> ParseRes.T; val stream_parse: instream -> ParseRes.T; val top_parse: unit -> ParseRes.T; end (* signature PARSE *) signature STREAM = sig type 'xa stream val streamify : (unit -> '_a) -> '_a stream val cons : '_a * '_a stream -> '_a stream val get : '_a stream -> '_a * '_a stream end signature PARSER = sig structure Token : TOKEN structure Stream : STREAM exception ParseError type pos type result type arg type svalue val makeLexer : (int -> string) -> (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 functor Parse (structure Globals : GLOBALS structure ParseRes : PARSERES structure Interface : INTERFACE structure Parser : PARSER sharing type Parser.pos = Interface.pos sharing type Parser.result = ParseRes.T sharing type Parser.arg = unit structure Tokens : FMEET_TOKENS sharing type Tokens.token = Parser.Token.token sharing type Tokens.svalue = Parser.svalue ) : PARSE = struct structure ParseRes = ParseRes open Globals val parse = fn (lookahead,reader : int -> string) => let val _ = Interface.init_line() val empty = !Interface.line val dummyEOF = Tokens.T_EOF(empty,empty) fun invoke lexer = Parser.parse(lookahead,lexer,Interface.error,()) fun loop lexer = let val (result,lexer) = invoke lexer val (nextToken,lexer) = Parser.Stream.get lexer in if Parser.sameToken(nextToken,dummyEOF) then result else loop lexer end in loop (Parser.makeLexer reader) end fun string_reader s = let val next = ref s in fn _ => !next before next := "" end val string_parse = fn s => parse (0, string_reader s) val file_parse = fn name => let val dev = open_in name in (parse (15,(fn i => input(dev,i)))) before close_in dev end fun prefix line len = substring(line,0,min(len,size line)) fun echo_line line = if (line = "\n") orelse (line="") then write line else if prefix line 3 = "%% " then write (substring(line,3,size(line)-3)) else if prefix line 2 = "%%" then write (substring(line,2,size(line)-2)) else write ("> " ^ line) fun convert_tabs s = implode (map (fn "\t" => " " | s => s) (explode s)); fun stream_parse dev = parse (15,(fn i => let val line = convert_tabs(input_line(dev)) val _ = echo_line line in line end)) val top_parse = fn () => parse (0, let val not_first_flag = ref(false) in fn i => (( if (!not_first_flag) then (write "> "; flush_out std_out) else not_first_flag := true ); input_line std_in) end) end (* functor Parse *) signature SYNTH = sig structure Globals: GLOBALS structure Trm: TRM structure Typ: TYP structure Leq: LEQ sharing Trm.Typ = Typ and Leq.Typ = Typ and Typ.Globals = Globals open Globals val synth: Typ.tenv -> Trm.T -> Typ.T end functor StrgHash() = struct val prime = 8388593 (* largest prime less than 2^23 *) val base = 128 fun hashString(str: string) : int = let val l = size str in case l of 0 => 0 | 1 => ord str | 2 => ordof(str,0) + base * ordof(str,1) | 3 => ordof(str,0) + base * (ordof(str,1) + base * ordof(str,2)) | _ => let fun loop (0,n) = n | loop (i,n) = let val i = i-1 val n' = (base * n + ordof(str,i)) in loop (i, (n' - prime * (n' quot prime))) end in loop (l,0) end end end (* structure StrgHash *) functor StringUtils() : STRINGUTILS = struct end signature LEXER = sig structure UserDeclarations : sig type ('a,'b) token type pos type svalue end val makeLexer : (int -> string) -> unit -> (UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token end functor FMEETLexFun(structure Tokens: FMEET_TOKENS structure Interface: INTERFACE) : LEXER= struct structure UserDeclarations = struct structure Tokens = Tokens structure Interface = Interface open Interface type pos = Interface.pos type svalue = Tokens.svalue type ('a,'b) token = ('a,'b) Tokens.token type lexresult= (svalue,pos) token val eof = fn () => Tokens.T_EOF(!line,!line) val str_begin = ref(!line); val str_const = ref([]:string list); end (* end of user routines *) exception LexError (* raised if illegal leaf action tried *) structure Internal = struct datatype yyfinstate = N of int type statedata = {fin : yyfinstate list, trans: string} (* transition & final state table *) val tab = let val s0 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" val s1 = "\007\007\007\007\007\007\007\007\007\097\099\007\007\007\007\007\ \\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\ \\097\007\007\007\096\095\007\094\093\092\007\007\091\089\088\086\ \\084\084\084\084\084\084\084\084\084\084\083\082\080\077\076\007\ \\075\072\010\010\010\010\010\010\010\010\010\010\010\010\070\010\ \\010\010\010\066\010\010\010\010\010\010\010\065\063\062\007\007\ \\061\010\010\053\048\045\042\010\010\040\010\010\010\010\010\035\ \\031\010\026\023\019\016\010\012\010\010\010\009\007\008\007\007\ \\007" val s3 = "\100\100\100\100\100\100\100\100\100\100\101\100\100\100\100\100\ \\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\ \\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\ \\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\ \\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\ \\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\ \\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\ \\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\100\ \\100" val s5 = "\102\102\102\102\102\102\102\102\102\102\104\102\102\102\102\102\ \\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\ \\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\ \\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\ \\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\ \\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\ \\103\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\ \\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\102\ \\102" val s10 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s12 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\013\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s13 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\014\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s14 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\015\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s16 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\017\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s17 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\018\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s19 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\020\011\000\000\000\000\000\ \\000" val s20 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\021\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s21 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\022\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s23 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\024\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s24 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\025\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s26 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\027\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s27 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\028\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s28 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\029\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s29 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\030\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s31 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\032\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s32 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\033\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s33 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\034\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s35 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\039\011\011\011\011\011\011\011\011\011\ \\036\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s36 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\037\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s37 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\038\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s40 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\041\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s42 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\043\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s43 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\044\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s45 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\046\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s46 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\047\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s48 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\049\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s49 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\050\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s50 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\051\011\011\011\011\011\000\000\000\000\000\ \\000" val s51 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\052\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s53 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\058\011\011\011\011\011\011\054\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s54 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\055\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s55 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\056\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s56 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\057\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s58 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\059\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s59 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\060\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s63 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\064\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" val s66 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\067\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s67 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\068\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s68 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\069\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s70 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\071\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s72 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\073\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s73 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\ \\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ \\000\011\011\011\011\011\011\011\011\011\011\011\011\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\011\ \\000\011\011\011\011\011\011\011\011\011\011\011\074\011\011\011\ \\011\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\ \\000" val s77 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\079\078\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" val s80 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\081\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" val s84 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\085\085\085\085\085\085\085\085\085\085\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" val s86 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\087\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" val s89 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\090\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" val s97 = "\000\000\000\000\000\000\000\000\000\098\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\098\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" in arrayoflist [{fin = [], trans = s0}, {fin = [(N 32)], trans = s1}, {fin = [(N 32)], trans = s1}, {fin = [], trans = s3}, {fin = [], trans = s3}, {fin = [], trans = s5}, {fin = [], trans = s5}, {fin = [(N 144)], trans = s0}, {fin = [(N 80),(N 144)], trans = s0}, {fin = [(N 78),(N 144)], trans = s0}, {fin = [(N 137),(N 144)], trans = s10}, {fin = [(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s12}, {fin = [(N 137)], trans = s13}, {fin = [(N 137)], trans = s14}, {fin = [(N 91),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s16}, {fin = [(N 137)], trans = s17}, {fin = [(N 3),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s19}, {fin = [(N 137)], trans = s20}, {fin = [(N 137)], trans = s21}, {fin = [(N 8),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s23}, {fin = [(N 137)], trans = s24}, {fin = [(N 12),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s26}, {fin = [(N 137)], trans = s27}, {fin = [(N 137)], trans = s28}, {fin = [(N 137)], trans = s29}, {fin = [(N 18),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s31}, {fin = [(N 137)], trans = s32}, {fin = [(N 137)], trans = s33}, {fin = [(N 122),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s35}, {fin = [(N 137)], trans = s36}, {fin = [(N 137)], trans = s37}, {fin = [(N 117),(N 137)], trans = s10}, {fin = [(N 99),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s40}, {fin = [(N 129),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s42}, {fin = [(N 137)], trans = s43}, {fin = [(N 103),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s45}, {fin = [(N 137)], trans = s46}, {fin = [(N 126),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s48}, {fin = [(N 137)], trans = s49}, {fin = [(N 137)], trans = s50}, {fin = [(N 137)], trans = s51}, {fin = [(N 24),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s53}, {fin = [(N 137)], trans = s54}, {fin = [(N 137)], trans = s55}, {fin = [(N 137)], trans = s56}, {fin = [(N 30),(N 137)], trans = s10}, {fin = [(N 137)], trans = s58}, {fin = [(N 137)], trans = s59}, {fin = [(N 96),(N 137)], trans = s10}, {fin = [(N 142),(N 144)], trans = s0}, {fin = [(N 72),(N 144)], trans = s0}, {fin = [(N 134),(N 144)], trans = s63}, {fin = [(N 132)], trans = s0}, {fin = [(N 70),(N 144)], trans = s0}, {fin = [(N 137),(N 144)], trans = s66}, {fin = [(N 137)], trans = s67}, {fin = [(N 137)], trans = s68}, {fin = [(N 112),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s70}, {fin = [(N 86),(N 137)], trans = s10}, {fin = [(N 137),(N 144)], trans = s72}, {fin = [(N 137)], trans = s73}, {fin = [(N 107),(N 137)], trans = s10}, {fin = [(N 42),(N 144)], trans = s0}, {fin = [(N 76),(N 144)], trans = s0}, {fin = [(N 52),(N 144)], trans = s77}, {fin = [(N 61)], trans = s0}, {fin = [(N 55)], trans = s0}, {fin = [(N 74),(N 144)], trans = s80}, {fin = [(N 58)], trans = s0}, {fin = [(N 44),(N 144)], trans = s0}, {fin = [(N 38),(N 144)], trans = s0}, {fin = [(N 140),(N 144)], trans = s84}, {fin = [(N 140)], trans = s84}, {fin = [(N 144)], trans = s86}, {fin = [(N 64)], trans = s0}, {fin = [(N 46),(N 144)], trans = s0}, {fin = [(N 144)], trans = s89}, {fin = [(N 83)], trans = s0}, {fin = [(N 48),(N 144)], trans = s0}, {fin = [(N 68),(N 144)], trans = s0}, {fin = [(N 66),(N 144)], trans = s0}, {fin = [(N 50),(N 144)], trans = s0}, {fin = [(N 36),(N 144)], trans = s0}, {fin = [(N 40),(N 144)], trans = s0}, {fin = [(N 32),(N 144)], trans = s97}, {fin = [(N 32)], trans = s97}, {fin = [(N 34)], trans = s0}, {fin = [(N 148)], trans = s0}, {fin = [(N 146)], trans = s0}, {fin = [(N 154)], trans = s0}, {fin = [(N 152),(N 154)], trans = s0}, {fin = [(N 150)], trans = s0}] end structure StartStates = struct datatype yystartstate = STARTSTATE of int (* start state definitions *) val COMMENT = STARTSTATE 3; val INITIAL = STARTSTATE 1; val STRING = STARTSTATE 5; end type result = UserDeclarations.lexresult exception LexerError (* raised if illegal leaf action tried *) end fun makeLexer yyinput = let val yyb = ref "\n" (* buffer *) val yybl = ref 1 (*buffer length *) val yybufpos = ref 1 (* location of next character to use *) val yygone = ref 1 (* position in file of beginning of buffer *) val yydone = ref false (* eof found yet? *) val yybegin = ref 1 (*Current 'start state' for lexer *) val YYBEGIN = fn (Internal.StartStates.STARTSTATE x) => yybegin := x fun lex () : Internal.result = let fun continue() = lex() in let fun scan (s,AcceptingLeaves : Internal.yyfinstate list list,l,i0) = let fun action (i,nil) = raise LexError | action (i,nil::l) = action (i-1,l) | action (i,(node::acts)::l) = case node of Internal.N yyk => (let val yytext = substring(!yyb,i0,i-i0) val yypos = i0+ !yygone open UserDeclarations Internal.StartStates in (yybufpos := i; case yyk of (* Application actions *) 103 => (Tokens.T_FOR(!line,!line)) | 107 => (Tokens.T_ALL(!line,!line)) | 112 => (Tokens.T_SOME(!line,!line)) | 117 => (Tokens.T_OPEN(!line,!line)) | 12 => (Tokens.T_SET(!line,!line)) | 122 => (Tokens.T_PACK(!line,!line)) | 126 => (Tokens.T_END (!line,!line)) | 129 => (Tokens.T_IN(!line,!line)) | 132 => (Tokens.T_BIGLAMBDA(!line,!line)) | 134 => (Tokens.T_LAMBDA(!line,!line)) | 137 => (Tokens.T_ID (yytext,!line,!line)) | 140 => (Tokens.T_INT_CONST (yytext,!line,!line)) | 142 => (str_begin:=(!line); str_const:=[]; YYBEGIN STRING; lex()) | 144 => (error ("ignoring illegal character" ^ yytext, !line,!line); lex()) | 146 => (next_line(); YYBEGIN INITIAL; lex()) | 148 => (lex()) | 150 => (next_line(); lex()) | 152 => (YYBEGIN INITIAL; Tokens.T_STR_CONST(implode(rev(!str_const)), !str_begin,!line)) | 154 => (str_const:=(yytext::(!str_const)); lex()) | 18 => (Tokens.T_RESET(!line,!line)) | 24 => (Tokens.T_DEBUG(!line,!line)) | 3 => (Tokens.T_USE(!line,!line)) | 30 => (Tokens.T_CHECK(!line,!line)) | 32 => (lex()) | 34 => (next_line(); lex()) | 36 => (YYBEGIN COMMENT; lex()) | 38 => (Tokens.T_COLON(!line,!line)) | 40 => (Tokens.T_DOLLAR(!line,!line)) | 42 => (Tokens.T_AT(!line,!line)) | 44 => (Tokens.T_EOF(!line,!line)) | 46 => (Tokens.T_DOT(!line,!line)) | 48 => (Tokens.T_COMMA(!line,!line)) | 50 => (Tokens.T_APOST(!line,!line)) | 52 => (Tokens.T_EQ(!line,!line)) | 55 => (Tokens.T_DOUBLEEQ(!line,!line)) | 58 => (Tokens.T_LEQ(!line,!line)) | 61 => (Tokens.T_DARROW(!line,!line)) | 64 => (Tokens.T_INTER(!line,!line)) | 66 => (Tokens.T_LPAREN(!line,!line)) | 68 => (Tokens.T_RPAREN(!line,!line)) | 70 => (Tokens.T_LBRACK(!line,!line)) | 72 => (Tokens.T_RBRACK(!line,!line)) | 74 => (Tokens.T_LANGLE(!line,!line)) | 76 => (Tokens.T_RANGLE(!line,!line)) | 78 => (Tokens.T_LCURLY(!line,!line)) | 8 => (Tokens.T_TYPE(!line,!line)) | 80 => (Tokens.T_RCURLY(!line,!line)) | 83 => (Tokens.T_ARROW(!line,!line)) | 86 => (Tokens.T_NS(!line,!line)) | 91 => (Tokens.T_WITH(!line,!line)) | 96 => (Tokens.T_CASE(!line,!line)) | 99 => (Tokens.T_OF(!line,!line)) | _ => raise Internal.LexerError ) end ) val {fin,trans} = Internal.tab sub s val NewAcceptingLeaves = fin::AcceptingLeaves in if l = !yybl then if trans = #trans(Internal.tab sub 0) then action(l,NewAcceptingLeaves) else let val newchars= if !yydone then "" else yyinput 1024 in if (size newchars)=0 then (yydone := true; if (l=i0) then UserDeclarations.eof () else action(l,NewAcceptingLeaves)) else (if i0=l then yyb := newchars else yyb := substring(!yyb,i0,l-i0)^newchars; yygone := !yygone+i0; yybl := size (!yyb); scan (s,AcceptingLeaves,l-i0,0)) end else let val NewChar = ordof(!yyb,l) val NewState = if NewChar<128 then ordof(trans,NewChar) else ordof(trans,128) in if NewState=0 then action(l,NewAcceptingLeaves) else scan(NewState,NewAcceptingLeaves,l+1,i0) end end in scan(!yybegin (* start *),nil,!yybufpos,!yybufpos) end end in lex end end functor Registry( type registeredtype ): REGISTRY = struct type registeredtype = registeredtype val registry = ref(nil: (string * (registeredtype->unit)) list) fun register name callback = registry := (name,callback)::(!registry) fun registerflag name flagref = registry := (name,(fn b => flagref := b))::(!registry) exception NotRegistered of string fun set_flag name v = let fun f [] = raise NotRegistered(name) | f ((n,callback)::tl) = if name=n then (callback v) else f tl in f (!registry) end fun set_all v = let fun f [] = () | f ((n,callback)::tl) = (callback v; f tl) in f (!registry) end end functor Typ( structure Globals: GLOBALS ) : TYPPVT = struct structure Globals = Globals open Globals open Pp datatype pretyp = PRETVAR of Id.T | PREARROW of pretyp * pretyp | PREALL of Id.T * pretyp * pretyp | PREMEET of pretyp list datatype T = TVAR of unit * int | ARROW of unit * T * T | ALL of {name:Id.T} * T * T | MEET of unit * (T list) type idindex = int val NS = MEET ((),[]) exception UnknownId of string datatype tenvelt = BND of Id.T * T | ABB of Id.T * T | VBND of Id.T * T datatype tenv = TENV of tenvelt list fun push_bound (TENV(te)) i t = TENV(BND(i,t)::te) fun push_abbrev (TENV(te)) i t = TENV(ABB(i,t)::te) fun push_binding (TENV(te)) i t = TENV(VBND(i,t)::te) val empty_tenv = TENV(nil) fun index (TENV(bvs)) i = let fun ind [] n = raise UnknownId(Id.tostr i) | ind (BND(i',_)::rest) n = if Id.== i i' then n else ind rest (n+1) | ind (VBND(i',_)::rest) n = if Id.== i i' then n else ind rest (n+1) | ind (ABB(i',_)::rest) n = if Id.== i i' then n else ind rest (n+1) in ind bvs 0 end exception TypeVariableOutOfRange of int fun old_lookup_name (TENV(te)) i = (case (nth (te,i)) of BND(name,_) => name | VBND(name,_) => name | ABB(name,_) => name) handle Nth => Id.intern(("")) fun lookup_name (TENV(te)) i = let fun l [] _ _ = Id.intern(("")) | l (hd::tl) rest 0 = let val name = case hd of BND(n,_) => n | VBND(n,_) => n | ABB(n,_) => n in if memq Id.== rest name then Id.intern ((Id.tostr name) ^ "^" ^ (makestring i)) else name end | l (hd::tl) rest j = let val name = case hd of BND(n,_) => n | VBND(n,_) => n | ABB(n,_) => n in l tl (name::rest) (j-1) end in l te [] i end exception WrongKindOfId of tenv * int * string fun lookup (TENV(te)) i = nth (te,i) handle Nth => raise TypeVariableOutOfRange(i) exception TriedToPopEmptyTEnv fun pop (TENV(hd::tl)) = TENV(tl) | pop _ = raise TriedToPopEmptyTEnv fun inner_relocate offset cutoff t = let fun r c (TVAR((),i)) = if i>=c then TVAR((),i + offset) else TVAR((),i) | r c (ARROW((),t1,t2)) = ARROW((), r c t1, r c t2) | r c (ALL({name=i},t1,t2)) = ALL({name=i}, r c t1, r (c+1) t2) | r c (MEET((),ts)) = MEET((), map (fn t => r c t) ts) in r cutoff t end fun relocate offset t = inner_relocate offset 0 t fun lookup_and_relocate (te) i = case lookup te i of BND(n,b) => BND(n, relocate (i+1) b) | VBND(n,b) => VBND(n, relocate (i+1) b) | ABB(n,b) => ABB(n, relocate (i+1) b) fun lookup_and_relocate_bound te i = case lookup_and_relocate te i of BND(_,b) => b | VBND(n,_) => raise WrongKindOfId(te,i,"tvar") | ABB(n,_) => raise WrongKindOfId(te,i,"tvar") fun lookup_and_relocate_binding te i = case lookup_and_relocate te i of BND(n,b) => raise WrongKindOfId(te,i,"var") | VBND(n,b) => b | ABB(n,b) => raise WrongKindOfId(te,i,"var") fun lookup_abbrev te i = case lookup_and_relocate te i of BND(n,_) => raise WrongKindOfId(te,i,"tabbrev") | VBND(n,b) => raise WrongKindOfId(te,i,"tabbrev") | ABB(n,b) => b fun debruijnify te (PRETVAR i) = TVAR((), index te i) | debruijnify te (PREARROW (pt1,pt2)) = ARROW((), debruijnify te pt1, debruijnify te pt2) | debruijnify te (PREALL (i,pt1,pt2)) = ALL({name=i}, debruijnify te pt1, debruijnify (push_bound te i NS) pt2) | debruijnify te (PREMEET pts) = MEET((), map (fn pt => debruijnify te pt) pts) fun tsubst_top targ tbody = let fun s i (t as TVAR(x,i')) = if i = i' then relocate i targ else if i < i' then TVAR(x,i'-1) else t | s i (ARROW(x,t1,t2)) = ARROW(x, s i t1, s i t2) | s i (ALL(x,t1,t2)) = ALL(x, s i t1, s (i+1) t2) | s i (MEET(x,ts)) = MEET(x, map (fn t => s i t) ts) in s 0 tbody end fun prt pp te t = let fun p te (TVAR(_,i)) = Pp.pwrite pp (Id.tostr (lookup_name te i)) | p te (ARROW(_,t1,t2)) = (Pp.pwrite pp "("; p te t1; Pp.pwrite pp "->"; p te t2; Pp.pwrite pp ")") | p te (ALL({name=i},t1,t2)) = (Pp.pwrite pp "(All "; Pp.pwrite pp (Id.tostr i); Pp.pwrite pp "<="; p te t1; Pp.pwrite pp ". "; p (push_bound te i t1) t2; Pp.pwrite pp ")") | p te (MEET(_,[])) = Pp.pwrite pp "NS" | p te (MEET(_,ts)) = (Pp.pwrite pp "/\\["; plist te ts; Pp.pwrite pp "]") and plist te [] = () | plist te [t] = p te t | plist te (hd::tl) = (p te hd; pwrite pp ","; plist te tl) in p te t end val short_tenvs = ref(true); val _ = registerflag "shorttenvs" short_tenvs; fun prt_tenv pp (TENV(te')) = let fun p [] = () | p [(BND(i,t))] = (Pp.pwrite pp (Id.tostr i); Pp.pwrite pp "<="; prt pp (TENV([])) t) | p ((BND(i,t))::tl) = (if (!short_tenvs) then pwrite pp "... " else p tl; Pp.pwrite pp ", "; Pp.break pp false 0; Pp.pwrite pp (Id.tostr i); Pp.pwrite pp "<="; prt pp (TENV(tl)) t) | p [(VBND(i,t))] = (Pp.pwrite pp (Id.tostr i); Pp.pwrite pp ":"; prt pp (TENV([])) t) | p ((VBND(i,t))::tl) = (if (!short_tenvs) then pwrite pp "... " else p tl; Pp.pwrite pp ", "; Pp.break pp false 0; Pp.pwrite pp (Id.tostr i); Pp.pwrite pp ":"; prt pp (TENV(tl)) t) | p [(ABB(i,t))] = (Pp.pwrite pp (Id.tostr i); Pp.pwrite pp "="; prt pp (TENV([])) t) | p ((ABB(i,t))::tl) = (if (!short_tenvs) then pwrite pp "... " else p tl; Pp.pwrite pp ", "; Pp.break pp false 0; Pp.pwrite pp (Id.tostr i); Pp.pwrite pp "="; prt pp (TENV(tl)) t) in Pp.pwrite pp "{"; Pp.setb pp; p te'; Pp.endb pp; Pp.pwrite pp "}" end end functor Leq( structure Typ: TYPPVT structure Globals: GLOBALS sharing Typ.Globals = Globals ) : LEQ = struct structure Typ = Typ structure Globals = Globals open Globals open Typ datatype lhsqueue = ARROW_LHS of Typ.T | ALL_LHS of Id.T * Typ.T datatype rhs_flag = EXPAND | FIX val DEBUG = ref(false) val _ = (registerflag "leq" DEBUG; registerflag "Leq" DEBUG) fun describe_rest pp te [] t flag = (Pp.pwrite pp "] -> "; Typ.prt pp te t; case flag of EXPAND => Pp.pwrite pp " (EXPAND)? " | FIX => Pp.pwrite pp " (FIX)? ") | describe_rest pp te [ARROW_LHS(t1)] t2 flag = (Typ.prt pp te t1; describe_rest pp te [] t2 flag) | describe_rest pp te ((ARROW_LHS(t1))::X2) t2 flag = (Typ.prt pp te t1; Pp.pwrite pp ","; describe_rest pp te X2 t2 flag) | describe_rest pp te [ALL_LHS(v,t1)] t2 flag = (Pp.pwrite pp (Id.tostr v); Pp.pwrite pp "<="; Typ.prt pp te t1; describe_rest pp (push_bound te v t1) [] t2 flag) | describe_rest pp te ((ALL_LHS(v,t1))::X2) t2 flag = (Pp.pwrite pp (Id.tostr v); Pp.pwrite pp "<="; Typ.prt pp te t1; Pp.pwrite pp ","; describe_rest pp (push_bound te v t1) X2 t2 flag) fun describe_problem pp te s X t flag = (Pp.setb pp; Typ.prt pp te s; Pp.break pp true ~3; Pp.pwrite pp " <= "; Pp.pwrite pp "["; describe_rest pp te X t flag; Pp.endb pp) fun bindings_in [] = 0 | bindings_in (ARROW_LHS(_)::tl) = bindings_in tl | bindings_in (ALL_LHS(_)::tl) = 1 + (bindings_in tl) fun leqq' te s X (MEET(_,ts)) EXPAND = forall (fn t => leqq te s X t EXPAND) ts | leqq' te s X (ARROW(_,t1,t2)) EXPAND = leqq te s (X@[ARROW_LHS(t1)]) t2 EXPAND | leqq' te s X (ALL({name=i},t1,t2)) EXPAND = leqq te s (X@[ALL_LHS(i,t1)]) t2 EXPAND | leqq' te s X (t as TVAR(_,vt)) EXPAND = let val bx = bindings_in X in if vt < bx then leqq te s X t FIX else case Typ.lookup te (vt - bx) of BND(_,_) => leqq te s X t FIX | VBND(n,_) => raise Typ.WrongKindOfId(te, vt - bx,"tvar or tabbrev") | ABB(_,ab) => leqq te s X (Typ.relocate (vt + bx) ab) EXPAND end | leqq' te (MEET(_,ss)) X (t as (TVAR(_,vt))) FIX = forsome (fn s => leqq te s X t FIX) ss | leqq' te (ARROW(_,s1,s2)) (ARROW_LHS(t1)::X) (t as (TVAR(_,vt))) FIX = (leqq te t1 [] s1 EXPAND) andalso (leqq te s2 X t FIX) | leqq' te (ALL(_,s1,s2)) (ALL_LHS(i,t1)::X) (t as (TVAR(_,vt))) FIX = (leqq (push_bound te i t1) s2 X t FIX) andalso (leqq te t1 [] s1 EXPAND) | leqq' te (TVAR(_,vs)) X (t as (TVAR(_,vt))) FIX = (vs = vt andalso (null X)) orelse (case lookup_and_relocate te vs of BND(_,bnd) => (leqq te bnd X t FIX) | VBND(n,ab) => raise Typ.WrongKindOfId(te,vs,"tvar or tabbrev") | ABB(_,ab) => (leqq te ab X t FIX)) | leqq' te s X t flag = false and leqq te s X t flag = wrap DEBUG "leqq" (fn () => leqq' te s X t flag) (fn () => describe_problem (stdpp()) te s X t flag) (fn b => write (if b then "Yes" else "No")) fun leq te s t = leqq te s [] t EXPAND end functor HashFun () = struct val version = 1.0 type ('a,'b) table = ('a*'a->bool) * (('a*int*'b) list array) * int fun create (sample'key :'1a) (equality :'1a * '1a -> bool) table'size (sample'value :'1b) :('1a,'1b) table = let val mt = tl [(sample'key, 0, sample'value)] in (equality, array (table'size, mt), table'size) end val defaultSize = 97 (* a prime; or try primes 37, 997 *) fun defaultEqual ((x :string), (y :string)) :bool = (x = y) fun createDefault (sample'value :'1b) :(string,'1b) table = let val mt = tl [("", 0, sample'value)] in (defaultEqual, array (defaultSize, mt), defaultSize) end fun enter ((equal, table, table'size) :('a,'b) table) key hash value = let val place = hash mod table'size val bucket = table sub place fun put'in [] = [(key,hash,value)] | put'in ((k,h,v)::tail) = if (h = hash) andalso equal (k, key) then (key,hash,value)::tail else (k,h,v)::(put'in tail) in update (table, place, put'in bucket) end fun remove ((equal, table, table'size) :('a,'b) table) key hash = let val place = hash mod table'size val bucket = table sub place fun take'out [] = [] | take'out ((k,h,v)::tail) = if (h = hash) andalso equal (k, key) then tail else (k,h,v)::(take'out tail) in update (table, place, take'out bucket) end fun lookup ((equal, table, table'size) :('a,'b) table) key hash = let val place = hash mod table'size val bucket = table sub place fun get'out [] = NONE | get'out ((k,h,v)::tail) = if (h = hash) andalso equal (k, key) then SOME v else get'out tail in get'out bucket end fun print ((_, table, table'size) :('a,'b) table) (print'key :'a -> unit) (print'value :'b -> unit) = let fun pr'bucket [] = () | pr'bucket ((key,hash,value)::rest) = (print'key key; String.print ": "; Integer.print hash; String.print ": "; print'value value; String.print "\n"; pr'bucket rest) fun pr i = if i >= table'size then () else case (table sub i) of [] => (pr (i+1)) | (b as (h::t)) => (String.print "["; Integer.print i; String.print "]\n"; pr'bucket b; pr (i+1)) in pr 0 end fun scan ((_, table, table'size) :('a,'b) table) operation = let fun map'bucket [] = () | map'bucket ((key,hash,value)::rest) = (operation key hash value; map'bucket rest) fun iter i = if i >= table'size then () else (map'bucket (table sub i); iter (i+1)) in iter 0 end fun fold ((_, table, table'size) :('a, 'b) table) (operation :'a -> int -> 'b -> 'g -> 'g) (init :'g) :'g = let fun fold'bucket [] acc = acc | fold'bucket ((key,hash,value)::rest) acc = fold'bucket rest (operation key hash value acc) fun iter i acc = if i >= table'size then acc else iter (i+1) (fold'bucket (table sub i) acc) in iter 0 init end fun scanUpdate ((_, table, table'size) :('a,'b) table) operation = let fun map'bucket [] = [] | map'bucket ((key,hash,value)::rest) = ((key,hash,operation key hash value)::(map'bucket rest)) fun iter i = if i >= table'size then () else (update (table, i, map'bucket (table sub i)); iter (i+1)) in iter 0 end fun eliminate ((_, table, table'size) :('a,'b) table) predicate = let fun map'bucket [] = [] | map'bucket ((key,hash,value)::rest) = if predicate key hash value then map'bucket rest else (key,hash,value)::(map'bucket rest) fun iter i = if i >= table'size then () else (update (table, i, map'bucket (table sub i)); iter (i+1)) in iter 0 end fun bucketLengths ((_, table, table'size) :('a,'b) table) (maxlen :int) :int array = let val count :int array = array (maxlen+1, 0) fun inc'sub x = let val y = min (x, maxlen) in update (count, y, (count sub y) + 1) end fun iter i = if i >= table'size then () else (inc'sub (length (table sub i)); iter (i+1)) in iter 0; count end end signature ORDSET = sig type set type elem exception Select_arb val app : (elem -> 'b) -> set -> unit and card: set -> int and closure: set * (elem -> set) -> set and difference: set * set -> set and elem_eq: (elem * elem -> bool) and elem_gt : (elem * elem -> bool) and empty: set and exists: (elem * set) -> bool and find : (elem * set) -> elem option and fold: ((elem * 'b) -> 'b) -> set -> 'b -> 'b and insert: (elem * set) -> set and is_empty: set -> bool and make_list: set -> elem list and make_set: (elem list -> set) and partition: (elem -> bool) -> (set -> set * set) and remove: (elem * set) -> set and revfold: ((elem * 'b) -> 'b) -> set -> 'b -> 'b and select_arb: set -> elem and set_eq: (set * set) -> bool and set_gt: (set * set) -> bool and singleton: (elem -> set) and union: set * set -> set end signature TABLE = sig type 'a table type key val size : 'a table -> int val empty: 'a table val exists: (key * 'a table) -> bool val find : (key * 'a table) -> 'a option val insert: ((key * 'a) * 'a table) -> 'a table val make_table : (key * 'a ) list -> 'a table val make_list : 'a table -> (key * 'a) list val fold : ((key * 'a) * 'b -> 'b) -> 'a table -> 'b -> 'b end signature HASH = sig type table type elem val size : table -> int val add : elem * table -> table val find : elem * table -> int option val exists : elem * table -> bool val empty : table end; functor ListOrdSet(B : sig type elem val gt : elem * elem -> bool val eq : elem * elem -> bool end ) : ORDSET = struct type elem = B.elem val elem_gt = B.gt val elem_eq = B.eq type set = elem list exception Select_arb val empty = nil val insert = fn (key,s) => let fun f (l as (h::t)) = if elem_gt(key,h) then h::(f t) else if elem_eq(key,h) then key::t else key::l | f nil = [key] in f s end val select_arb = fn nil => raise Select_arb | a::b => a val exists = fn (key,s) => let fun f (h::t) = if elem_gt(key,h) then f t else elem_eq(h,key) | f nil = false in f s end val find = fn (key,s) => let fun f (h::t) = if elem_gt(key,h) then f t else if elem_eq(h,key) then SOME h else NONE | f nil = NONE in f s end val revfold = List.revfold val fold = List.fold val app = List.app fun set_eq(h::t,h'::t') = (case elem_eq(h,h') of true => set_eq(t,t') | a => a) | set_eq(nil,nil) = true | set_eq _ = false fun set_gt(h::t,h'::t') = (case elem_gt(h,h') of false => (case (elem_eq(h,h')) of true => set_gt(t,t') | a => a) | a => a) | set_gt(_::_,nil) = true | set_gt _ = false fun union(a as (h::t),b as (h'::t')) = if elem_gt(h',h) then h::union(t,b) else if elem_eq(h,h') then h::union(t,t') else h'::union(a,t') | union(nil,s) = s | union(s,nil) = s val make_list = fn s => s val is_empty = fn nil => true | _ => false val make_set = fn l => List.fold insert l nil val partition = fn f => fn s => fold (fn (e,(yes,no)) => if (f e) then (e::yes,no) else (e::no,yes)) s (nil,nil) val remove = fn (e,s) => let fun f (l as (h::t)) = if elem_gt(h,e) then l else if elem_eq(h,e) then t else h::(f t) | f nil = nil in f s end (* difference: X-Y *) fun difference (nil,_) = nil | difference (r,nil) = r | difference (a as (h::t),b as (h'::t')) = if elem_gt (h',h) then h::difference(t,b) else if elem_eq(h',h) then difference(t,t') else difference(a,t') fun singleton X = [X] fun card(S) = fold (fn (a,count) => count+1) S 0 local fun closure'(from, f, result) = if is_empty from then result else let val (more,result) = fold (fn (a,(more',result')) => let val more = f a val new = difference(more,result) in (union(more',new),union(result',new)) end) from (empty,result) in closure'(more,f,result) end in fun closure(start, f) = closure'(start, f, start) end end functor RbOrdSet (B : sig type elem val eq : (elem*elem) -> bool val gt : (elem*elem) -> bool end ) : ORDSET = struct type elem = B.elem val elem_gt = B.gt val elem_eq = B.eq datatype Color = RED | BLACK abstype set = EMPTY | TREE of (B.elem * Color * set * set) with exception Select_arb val empty = EMPTY fun insert(key,t) = let fun f EMPTY = TREE(key,RED,EMPTY,EMPTY) | f (TREE(k,BLACK,l,r)) = if elem_gt (key,k) then case f r of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) => (case l of TREE(lk,RED,ll,lr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll), TREE(rk,RED,rlr,rr))) | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) => (case l of TREE(lk,RED,ll,lr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr)) | r => TREE(k,BLACK,l,r) else if elem_gt(k,key) then case f l of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) => (case r of TREE(rk,RED,rl,rr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl), TREE(k,RED,lrr,r))) | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) => (case r of TREE(rk,RED,rl,rr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r))) | l => TREE(k,BLACK,l,r) else TREE(key,BLACK,l,r) | f (TREE(k,RED,l,r)) = if elem_gt(key,k) then TREE(k,RED,l, f r) else if elem_gt(k,key) then TREE(k,RED, f l, r) else TREE(key,RED,l,r) in case f t of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r) | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r) | t => t end fun select_arb (TREE(k,_,l,r)) = k | select_arb EMPTY = raise Select_arb fun exists(key,t) = let fun look EMPTY = false | look (TREE(k,_,l,r)) = if elem_gt(k,key) then look l else if elem_gt(key,k) then look r else true in look t end fun find(key,t) = let fun look EMPTY = NONE | look (TREE(k,_,l,r)) = if elem_gt(k,key) then look l else if elem_gt(key,k) then look r else SOME k in look t end fun revfold f t start = let fun scan (EMPTY,value) = value | scan (TREE(k,_,l,r),value) = scan(r,f(k,scan(l,value))) in scan(t,start) end fun fold f t start = let fun scan(EMPTY,value) = value | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value))) in scan(t,start) end fun app f t = let fun scan EMPTY = () | scan(TREE(k,_,l,r)) = (scan l; f k; scan r) in scan t end fun set_eq (tree1 as (TREE _),tree2 as (TREE _)) = let datatype pos = L | R | M exception Done fun getvalue(stack as ((a,position)::b)) = (case a of (TREE(k,_,l,r)) => (case position of L => getvalue ((l,L)::(a,M)::b) | M => (k,case r of EMPTY => b | _ => (a,R)::b) | R => getvalue ((r,L)::b) ) | EMPTY => getvalue b ) | getvalue(nil) = raise Done fun f (nil,nil) = true | f (s1 as (_ :: _),s2 as (_ :: _ )) = let val (v1,news1) = getvalue s1 and (v2,news2) = getvalue s2 in (elem_eq(v1,v2)) andalso f(news1,news2) end | f _ = false in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false end | set_eq (EMPTY,EMPTY) = true | set_eq _ = false fun set_gt (tree1,tree2) = let datatype pos = L | R | M exception Done fun getvalue(stack as ((a,position)::b)) = (case a of (TREE(k,_,l,r)) => (case position of L => getvalue ((l,L)::(a,M)::b) | M => (k,case r of EMPTY => b | _ => (a,R)::b) | R => getvalue ((r,L)::b) ) | EMPTY => getvalue b ) | getvalue(nil) = raise Done fun f (nil,nil) = false | f (s1 as (_ :: _),s2 as (_ :: _ )) = let val (v1,news1) = getvalue s1 and (v2,news2) = getvalue s2 in (elem_gt(v1,v2)) orelse (elem_eq(v1,v2) andalso f(news1,news2)) end | f (_,nil) = true | f (nil,_) = false in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false end fun is_empty S = (let val _ = select_arb S in false end handle Select_arb => true) fun make_list S = fold (op ::) S nil fun make_set l = List.fold insert l empty fun partition F S = fold (fn (a,(Yes,No)) => if F(a) then (insert(a,Yes),No) else (Yes,insert(a,No))) S (empty,empty) fun remove(X, XSet) = let val (YSet, _) = partition (fn a => not (elem_eq (X, a))) XSet in YSet end fun difference(Xs, Ys) = fold (fn (p as (a,Xs')) => if exists(a,Ys) then Xs' else insert p) Xs empty fun singleton X = insert(X,empty) fun card(S) = fold (fn (_,count) => count+1) S 0 fun union(Xs,Ys)= fold insert Ys Xs local fun closure'(from, f, result) = if is_empty from then result else let val (more,result) = fold (fn (a,(more',result')) => let val more = f a val new = difference(more,result) in (union(more',new),union(result',new)) end) from (empty,result) in closure'(more,f,result) end in fun closure(start, f) = closure'(start, f, start) end end end functor Table (B : sig type key val gt : (key * key) -> bool end ) : TABLE = struct datatype Color = RED | BLACK type key = B.key abstype 'a table = EMPTY | TREE of ((B.key * 'a ) * Color * 'a table * 'a table) with val empty = EMPTY fun insert(elem as (key,data),t) = let val key_gt = fn (a,_) => B.gt(key,a) val key_lt = fn (a,_) => B.gt(a,key) fun f EMPTY = TREE(elem,RED,EMPTY,EMPTY) | f (TREE(k,BLACK,l,r)) = if key_gt k then case f r of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) => (case l of TREE(lk,RED,ll,lr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll), TREE(rk,RED,rlr,rr))) | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) => (case l of TREE(lk,RED,ll,lr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr)) | r => TREE(k,BLACK,l,r) else if key_lt k then case f l of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) => (case r of TREE(rk,RED,rl,rr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl), TREE(k,RED,lrr,r))) | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) => (case r of TREE(rk,RED,rl,rr) => TREE(k,RED,TREE(lk,BLACK,ll,lr), TREE(rk,BLACK,rl,rr)) | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r))) | l => TREE(k,BLACK,l,r) else TREE(elem,BLACK,l,r) | f (TREE(k,RED,l,r)) = if key_gt k then TREE(k,RED,l, f r) else if key_lt k then TREE(k,RED, f l, r) else TREE(elem,RED,l,r) in case f t of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r) | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r) | t => t end fun exists(key,t) = let fun look EMPTY = false | look (TREE((k,_),_,l,r)) = if B.gt(k,key) then look l else if B.gt(key,k) then look r else true in look t end fun find(key,t) = let fun look EMPTY = NONE | look (TREE((k,data),_,l,r)) = if B.gt(k,key) then look l else if B.gt(key,k) then look r else SOME data in look t end fun fold f t start = let fun scan(EMPTY,value) = value | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value))) in scan(t,start) end fun make_table l = List.fold insert l empty fun size S = fold (fn (_,count) => count+1) S 0 fun make_list table = fold (op ::) table nil end end; functor Hash(B : sig type elem val gt : elem * elem -> bool end) : HASH = struct type elem=B.elem structure HashTable = Table(type key=B.elem val gt = B.gt) type table = {count : int, table : int HashTable.table} val empty = {count=0,table=HashTable.empty} val size = fn {count,table} => count val add = fn (e,{count,table}) => {count=count+1,table=HashTable.insert((e,count),table)} val find = fn (e,{table,count}) => HashTable.find(e,table) val exists = fn (e,{table,count}) => HashTable.exists(e,table) end; functor Interface () : INTERFACE = struct type pos = int val line = ref 0 fun init_line () = (line := 0) fun next_line () = (line := !line + 1) fun error (errmsg,line:pos,_) = output (std_out, ("Line " ^ (makestring line) ^ ": " ^ errmsg ^ "\n")) end (* functor INTERFACE *) functor Globals( structure Wr: WR structure Pp: PP structure WrMgt: WRMGT structure ListUtils: LISTUTILS structure StringUtils: STRINGUTILS structure DebugUtils: DEBUGUTILS structure Id: ID structure Registry: REGISTRY sharing Pp.Wr = Wr and WrMgt.Pp = Pp and type Registry.registeredtype = bool ) : GLOBALS = struct structure Wr = Wr; open Wr; structure Pp = Pp; open Pp; structure WrMgt = WrMgt; open WrMgt; structure Id = Id; structure Registry = Registry open ListUtils open StringUtils open DebugUtils open Registry exception CantHappen end signature TRMPVT = sig structure Globals: GLOBALS structure Typ: TYPPVT sharing Typ.Globals = Globals open Globals datatype pretrm = PREVAR of Id.T | PREABS of Id.T * Typ.pretyp * pretrm | PREAPP of pretrm * pretrm | PRETABS of Id.T * Typ.pretyp * pretrm | PRETAPP of pretrm * Typ.pretyp | PREFOR of Id.T * (Typ.pretyp list) * pretrm datatype T = VAR of unit * int | ABS of {name:Id.T} * Typ.T * T | APP of unit * T * T | TABS of {name:Id.T} * Typ.T * T | TAPP of unit * T * Typ.T | FOR of {name:Id.T} * (Typ.T list) * T exception UnknownId of string val debruijnify: Typ.tenv -> pretrm -> T val prt: Pp.Pp -> Typ.tenv -> T -> unit end functor DebugUtils( structure WrMgt: WRMGT ) : DEBUGUTILS = struct open WrMgt open Pp; val level = ref(0); (* $$$ belongs in globals: *) fun unwind_protect f cleanup = (f()) handle e => (cleanup(); raise e) fun do_wrap pp name f pbefore pafter = (pwrite pp "["; setb pp; pwrite pp (makestring (!level)); pwrite pp "] "; pwrite pp name; pwrite pp "? "; pbefore(); pwrite pp "\n"; level := (!level) + 1; let val result = unwind_protect f (fn () => level := (!level) - 1) in level := (!level) - 1; break pp true ~3; pwrite pp " ["; pwrite pp (makestring (!level)); pwrite pp "] "; pwrite pp name; pwrite pp ": "; pafter(result); pwrite pp "\n"; endb pp; result end ) fun wrap DEBUG name f pbefore pafter = if (not (!DEBUG)) then f() else do_wrap (stdpp()) name f pbefore pafter; end functor Trm( structure Globals: GLOBALS structure Typ: TYPPVT sharing Typ.Globals = Globals ) : TRMPVT = struct structure Globals = Globals structure Typ = Typ open Globals open Typ open Pp datatype pretrm = PREVAR of Id.T | PREABS of Id.T * pretyp * pretrm | PREAPP of pretrm * pretrm | PRETABS of Id.T * pretyp * pretrm | PRETAPP of pretrm * pretyp | PREFOR of Id.T * (pretyp list) * pretrm datatype T = VAR of unit * int | ABS of {name:Id.T} * Typ.T * T | APP of unit * T * T | TABS of {name:Id.T} * Typ.T * T | TAPP of unit * T * Typ.T | FOR of {name:Id.T} * (Typ.T list) * T fun debruijnify te (PREVAR i) = VAR((), index te i) | debruijnify te (PREABS(i,ptyp,ptrm)) = ABS({name=i}, Typ.debruijnify te ptyp, debruijnify (push_binding te i NS) ptrm) | debruijnify te (PREAPP(ptrm1,ptrm2)) = APP((), debruijnify te ptrm1, debruijnify te ptrm2) | debruijnify te (PRETABS(i,ptyp,ptrm)) = TABS({name=i}, Typ.debruijnify te ptyp, debruijnify (push_bound te i NS) ptrm) | debruijnify te (PRETAPP(ptrm,ptyp)) = TAPP((), debruijnify te ptrm, Typ.debruijnify te ptyp) | debruijnify te (PREFOR(i,ptyps,ptrm)) = FOR({name=i}, map (fn pt => Typ.debruijnify te pt) ptyps, debruijnify (push_bound te i NS) ptrm) fun prt pp te trm = let fun p te (VAR(_,i)) = Pp.pwrite pp (Id.tostr (lookup_name te i)) | p te (ABS({name=i},t,body)) = (Pp.pwrite pp "(\\"; Pp.pwrite pp (Id.tostr i); Pp.pwrite pp ":"; Typ.prt pp te t; Pp.pwrite pp ". "; p (push_binding te i t) body; Pp.pwrite pp ")") | p te (APP(_,trm1,trm2)) = (Pp.pwrite pp "("; p te trm1; Pp.pwrite pp " "; p te trm2; Pp.pwrite pp ")") | p te (TABS({name=i},t,body)) = (Pp.pwrite pp "(\\\\"; Pp.pwrite pp (Id.tostr i); Pp.pwrite pp "<="; Typ.prt pp te t; Pp.pwrite pp ". "; p (push_bound te i t) body; Pp.pwrite pp ")") | p te (TAPP(_,trm1,t)) = (Pp.pwrite pp "("; p te trm1; Pp.pwrite pp " ["; Typ.prt pp te t; Pp.pwrite pp "])") | p te (FOR({name=i},ts,body)) = (Pp.pwrite pp "(for "; Pp.pwrite pp (Id.tostr i); Pp.pwrite pp " in "; mapunit_tuple (fn t => Typ.prt pp te t) (fn () => Pp.pwrite pp ",") ts; Pp.pwrite pp ". "; p (push_abbrev te i NS) body; Pp.pwrite pp ")") in p te trm end end functor ListUtils() : LISTUTILS = struct fun mapunit f l = let fun mu [] = () | mu (hd::tl) = (f hd; mu tl) in mu l end fun mapunit_tuple f betw ts = let fun mut [] = () | mut [e] = f e | mut (e::tl) = (f e; betw(); mut tl) in mut ts end fun mapfold fm ff z = let fun m [] = z | m (hd::tl) = ff (fm hd) (m tl) in m end fun memq eq l e = let fun m [] = false | m (hd::tl) = (eq e hd) orelse (m tl) in m l end fun mapappend f l = let fun ma [] = [] | ma (hd::tl) = (f hd) @ (ma tl) in ma l end fun filter b l = let fun f [] = [] | f (hd::tl) = if (b hd) then hd::(f tl) else f tl in f l end fun forall f = mapfold f (fn x => fn y => x andalso y) true fun forsome f = mapfold f (fn x => fn y => x orelse y) false end functor Synth( structure Globals: GLOBALS structure Typ: TYPPVT structure Trm: TRMPVT structure Leq: LEQ sharing Typ.Globals = Globals and Trm.Typ = Typ and Leq.Typ = Typ ) : SYNTH = struct structure Globals = Globals structure Typ = Typ structure Trm = Trm structure Leq = Leq open Globals open Typ open Trm val DEBUG = ref(false) val _ = (registerflag "synth" DEBUG; registerflag "Synth" DEBUG) fun arrowbasis te t = let fun ab (TVAR(_,v)) = (case lookup_and_relocate te v of BND(_,b) => ab b | VBND(n,b) => raise Typ.WrongKindOfId(te,v,"tvar or abbrev") | ABB(_,b) => ab b) | ab (t as ARROW(_)) = [t] | ab (ALL(_)) = [] | ab (MEET(_,ts)) = mapappend ab ts in ab t end fun allbasis te t = let fun ab (TVAR(_,v)) = (case lookup_and_relocate te v of BND(_,b) => ab b | VBND(n,b) => raise Typ.WrongKindOfId(te,v,"tvar or abbrev") | ABB(_,b) => ab b) | ab (t as ARROW(_)) = [] | ab (t as ALL(_)) = [t] | ab (MEET(_,ts)) = mapappend ab ts in ab t end fun synth' te (VAR(_,v)) = Typ.lookup_and_relocate_binding te v | synth' te (ABS({name=i},t,body)) = let val t_body = synth (push_binding te i t) body val t' = relocate ~1 t_body in ARROW((),t,t') end | synth' te (APP(_,trm1,trm2)) = let val t1 = synth te trm1 and t2 = synth te trm2 val basis = arrowbasis te t1 fun collect_apps [] = [] | collect_apps ((ARROW(_,tb1,tb2))::tl) = if Leq.leq te t2 tb1 then tb2::(collect_apps tl) else (collect_apps tl) | collect_apps _ = raise CantHappen val ts = collect_apps basis in MEET((),ts) end | synth' te (TABS({name=i},t,body)) = let val t' = synth (push_bound te i t) body in ALL({name=i},t,t') end | synth' te (TAPP(_,body,t)) = let val t_body = synth te body val basis = allbasis te t_body fun collect_apps [] = [] | collect_apps ((ALL(_,t1,t2))::tl) = if Leq.leq te t t1 then (tsubst_top t t2)::(collect_apps tl) else (collect_apps tl) | collect_apps _ = raise CantHappen val ts = collect_apps basis in MEET((),ts) end | synth' te (FOR({name=i},ts,body)) = let fun f t = let val tb = synth (push_abbrev te i t) body val tb' = tsubst_top t tb in tb' end in MEET((), map f ts) end and synth te e = wrap (DEBUG) "synth" (fn () => synth' te e) (fn () => (Trm.prt (stdpp()) te e; Pp.pwrite (stdpp()) "\n"; Typ.prt_tenv (stdpp()) te)) (fn t => (Typ.prt (stdpp()) te t)) end functor FMEETLrValsFun ( structure Token : TOKEN structure Globals : GLOBALS structure ParseRes : PARSERES ) : FMEET_LRVALS = struct structure ParserData= struct structure Header = struct structure ParseRes = ParseRes open ParseRes open Trm open Typ open Globals end structure LrTable = Token.LrTable structure Token = Token local open LrTable in val table=let val actionT = "\ \\001\000\022\000\014\000\021\000\023\000\020\000\ \\024\000\019\000\025\000\018\000\026\000\017\000\027\000\016\000\ \\028\000\015\000\029\000\014\000\030\000\013\000\031\000\012\000\ \\032\000\011\000\033\000\010\000\040\000\009\000\000\000\001\000\ \\000\000\141\000\ \\014\000\025\000\016\000\024\000\025\000\018\000\000\000\140\000\ \\000\000\116\000\ \\000\000\147\000\ \\005\000\028\000\008\000\027\000\009\000\026\000\000\000\137\000\ \\000\000\118\000\ \\025\000\018\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\025\000\038\000\000\000\001\000\ \\025\000\039\000\000\000\001\000\ \\025\000\040\000\000\000\001\000\ \\025\000\018\000\000\000\001\000\ \\025\000\042\000\000\000\001\000\ \\000\000\139\000\ \\000\000\138\000\ \\000\000\136\000\ \\025\000\018\000\000\000\001\000\ \\025\000\018\000\000\000\001\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\000\000\117\000\ \\000\000\149\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\036\000\053\000\000\000\001\000\ \\006\000\054\000\000\000\134\000\ \\005\000\057\000\012\000\056\000\022\000\055\000\000\000\001\000\ \\000\000\122\000\ \\025\000\018\000\000\000\001\000\ \\000\000\126\000\ \\025\000\018\000\000\000\001\000\ \\016\000\060\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\000\000\120\000\ \\000\000\121\000\ \\000\000\119\000\ \\005\000\063\000\009\000\062\000\000\000\001\000\ \\000\000\110\000\ \\036\000\064\000\000\000\001\000\ \\002\000\066\000\005\000\065\000\006\000\054\000\000\000\134\000\ \\003\000\067\000\000\000\001\000\ \\015\000\068\000\000\000\001\000\ \\000\000\137\000\ \\012\000\056\000\017\000\069\000\022\000\055\000\000\000\001\000\ \\015\000\070\000\000\000\001\000\ \\012\000\056\000\022\000\055\000\000\000\114\000\ \\000\000\115\000\ \\012\000\056\000\022\000\055\000\000\000\112\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\025\000\018\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\002\000\078\000\005\000\077\000\000\000\001\000\ \\002\000\080\000\005\000\079\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\012\000\056\000\015\000\082\000\022\000\055\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\000\000\148\000\ \\000\000\151\000\ \\000\000\150\000\ \\002\000\089\000\000\000\001\000\ \\006\000\090\000\012\000\056\000\022\000\055\000\000\000\132\000\ \\000\000\135\000\ \\012\000\056\000\022\000\055\000\000\000\124\000\ \\012\000\056\000\000\000\123\000\ \\012\000\056\000\022\000\055\000\000\000\109\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\017\000\095\000\000\000\001\000\ \\000\000\127\000\ \\012\000\056\000\022\000\055\000\000\000\113\000\ \\012\000\056\000\022\000\055\000\000\000\111\000\ \\002\000\096\000\000\000\001\000\ \\002\000\097\000\012\000\056\000\022\000\055\000\000\000\001\000\ \\000\000\143\000\ \\002\000\098\000\000\000\001\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\002\000\101\000\012\000\056\000\022\000\055\000\000\000\001\000\ \\012\000\056\000\022\000\055\000\000\000\130\000\ \\002\000\102\000\012\000\056\000\022\000\055\000\000\000\001\000\ \\012\000\056\000\022\000\055\000\000\000\128\000\ \\000\000\125\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\014\000\021\000\023\000\020\000\024\000\019\000\ \\025\000\018\000\026\000\017\000\027\000\016\000\040\000\009\000\000\000\001\000\ \\000\000\146\000\ \\000\000\133\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\014\000\037\000\022\000\036\000\025\000\018\000\ \\035\000\035\000\037\000\034\000\043\000\033\000\000\000\001\000\ \\000\000\145\000\ \\000\000\144\000\ \\000\000\142\000\ \\012\000\056\000\022\000\055\000\000\000\131\000\ \\012\000\056\000\022\000\055\000\000\000\129\000\ \\001\000\000\000\004\000\000\000\000\000\001\000\ \" val gotoT = "\ \\001\000\106\000\002\000\006\000\003\000\005\000\ \\005\000\004\000\008\000\003\000\009\000\002\000\010\000\001\000\000\000\000\000\ \\000\000\000\000\ \\003\000\021\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\028\000\004\000\027\000\000\000\000\000\ \\003\000\030\000\006\000\029\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\039\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\042\000\004\000\041\000\000\000\000\000\ \\003\000\043\000\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\044\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\030\000\006\000\046\000\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\047\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\003\000\030\000\006\000\048\000\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\049\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\003\000\030\000\006\000\050\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\056\000\000\000\000\000\ \\000\000\000\000\ \\003\000\057\000\000\000\000\000\ \\000\000\000\000\ \\003\000\030\000\006\000\059\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\030\000\006\000\070\000\007\000\069\000\000\000\000\000\ \\003\000\028\000\004\000\071\000\000\000\000\000\ \\003\000\030\000\006\000\072\000\000\000\000\000\ \\003\000\030\000\006\000\073\000\000\000\000\000\ \\003\000\030\000\006\000\074\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\030\000\006\000\070\000\007\000\079\000\000\000\000\000\ \\000\000\000\000\ \\003\000\030\000\006\000\081\000\000\000\000\000\ \\003\000\030\000\006\000\082\000\000\000\000\000\ \\003\000\030\000\006\000\070\000\007\000\083\000\000\000\000\000\ \\003\000\030\000\006\000\084\000\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\085\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\003\000\030\000\006\000\070\000\007\000\086\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\030\000\006\000\089\000\000\000\000\000\ \\003\000\030\000\006\000\090\000\000\000\000\000\ \\003\000\030\000\006\000\091\000\000\000\000\000\ \\003\000\030\000\006\000\092\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\097\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\003\000\030\000\006\000\070\000\007\000\098\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\101\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\102\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\003\000\045\000\005\000\004\000\008\000\103\000\ \\009\000\002\000\010\000\001\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\003\000\030\000\006\000\104\000\000\000\000\000\ \\003\000\030\000\006\000\105\000\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \\000\000\000\000\ \" val numstates = 107 val string_to_int = fn(s,index) => (ordof(s,index) + ordof(s,index+1)*256,index+2) val convert_string_to_row = fn (conv_key,conv_entry) => fn(s,index) => let fun f (r,index) = let val (num,index) = string_to_int(s,index) val (i,index) = string_to_int(s,index) in if num=0 then ((rev r,conv_entry i),index) else f((conv_key (num-1),conv_entry i)::r,index) end in f(nil,index) end val convert_string_to_row_list = fn conv_funcs => fn s => let val convert_row =convert_string_to_row conv_funcs fun f(r,index) = if index < String.length s then let val (newlist,index) = convert_row (s,index) in f(newlist::r,index) end else rev r in f(nil,0) end val entry_to_action = fn j => if j=0 then ACCEPT else if j=1 then ERROR else if j >= (numstates+2) then REDUCE (j-numstates-2) else SHIFT (STATE (j-2)) val make_goto_table = convert_string_to_row_list(NT,STATE) val make_action_table=convert_string_to_row_list(T,entry_to_action) val gotoT = map (fn (a,b) => a) (make_goto_table gotoT) val actionT = make_action_table actionT in LrTable.mkLrTable {actions=actionT,gotos=gotoT, numStates=numstates,initialState=STATE 0} end end local open Header in type pos = int type arg = unit structure MlyValue = struct datatype svalue = VOID | ntVOID of unit | T_STR_CONST of (string) | T_INT_CONST of (string) | T_ID of (string) | bnd of (ParseRes.Trm.pretrm) | appl of (ParseRes.Trm.pretrm) | term of (ParseRes.Trm.pretrm) | tplist of (ParseRes.Typ.pretyp list) | tp of (ParseRes.Typ.pretyp) | const of (Id.T) | idlist of (Id.T list) | id of (Id.T) | setcmd of (ParseRes.T) | start of (ParseRes.T) end type svalue = MlyValue.svalue type result = ParseRes.T end structure EC= struct open LrTable val is_keyword = fn _ => false val preferred_insert = fn (T 1) => true | (T 38) => true | _ => false val preferred_subst = fn _ => nil val noShift = fn (T 3) => true | (T 0) => true | _ => false val showTerminal = fn (T 0) => "T_EOF" | (T 1) => "T_DOT" | (T 2) => "T_COLON" | (T 3) => "T_SEMICOLON" | (T 4) => "T_LEQ" | (T 5) => "T_COMMA" | (T 6) => "T_APOST" | (T 7) => "T_EQ" | (T 8) => "T_DOUBLEEQ" | (T 9) => "T_DOLLAR" | (T 10) => "T_AT" | (T 11) => "T_ARROW" | (T 12) => "T_DARROW" | (T 13) => "T_LPAREN" | (T 14) => "T_RPAREN" | (T 15) => "T_LBRACK" | (T 16) => "T_RBRACK" | (T 17) => "T_LANGLE" | (T 18) => "T_RANGLE" | (T 19) => "T_LCURLY" | (T 20) => "T_RCURLY" | (T 21) => "T_INTER" | (T 22) => "T_LAMBDA" | (T 23) => "T_BIGLAMBDA" | (T 24) => "T_ID" | (T 25) => "T_INT_CONST" | (T 26) => "T_STR_CONST" | (T 27) => "T_USE" | (T 28) => "T_TYPE" | (T 29) => "T_SET" | (T 30) => "T_RESET" | (T 31) => "T_DEBUG" | (T 32) => "T_CHECK" | (T 33) => "T_WITH" | (T 34) => "T_ALL" | (T 35) => "T_IN" | (T 36) => "T_NS" | (T 37) => "T_CASE" | (T 38) => "T_OF" | (T 39) => "T_FOR" | (T 40) => "T_OBSERVE" | (T 41) => "T_INSTALL" | (T 42) => "T_SOME" | (T 43) => "T_OPEN" | (T 44) => "T_END" | (T 45) => "T_PACK" | _ => "bogus-term" val errtermvalue= let open Header in fn _ => MlyValue.VOID end val terms = (T 0) :: (T 1) :: (T 2) :: (T 3) :: (T 4) :: (T 5) :: (T 6 ) :: (T 7) :: (T 8) :: (T 9) :: (T 10) :: (T 11) :: (T 12) :: (T 13) :: (T 14) :: (T 15) :: (T 16) :: (T 17) :: (T 18) :: (T 19) :: (T 20) :: (T 21) :: (T 22) :: (T 23) :: (T 27) :: (T 28) :: (T 29) :: (T 30) :: (T 31) :: (T 32) :: (T 33) :: (T 34) :: (T 35) :: (T 36) :: (T 37) :: (T 38) :: (T 39) :: (T 40) :: (T 41) :: (T 42) :: (T 43) :: (T 44) :: (T 45) :: nil end structure Actions = struct exception mlyAction of int val actions = let open Header in fn (i392,defaultPos,stack, (()):arg) => case (i392,stack) of (0,(_,(MlyValue.tp (tp2),tp2left,tp2right)) :: (_,(_,T_LEQleft as T_LEQ1left,T_LEQright as T_LEQ1right)) :: (_,(MlyValue.tp (tp1 as tp), tpleft as tp1left,tpright as tp1right)) :: (_,(_,T_CHECKleft as T_CHECK1left,T_CHECKright as T_CHECK1right)) :: rest671) => let val result = MlyValue.start (((Leq(tp1,tp2)))) in (LrTable.NT 0,(result,T_CHECK1left,tp2right),rest671) end | (1,(_,(MlyValue.T_ID (T_ID1 as T_ID),T_IDleft as T_ID1left, T_IDright as T_ID1right)) :: (_,(_,T_USEleft as T_USE1left, T_USEright as T_USE1right)) :: rest671) => let val result = MlyValue.start (((Use(T_ID)))) in (LrTable.NT 0,(result,T_USE1left,T_ID1right),rest671) end | (2,(_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right )) :: (_,(_,T_LEQleft as T_LEQ1left,T_LEQright as T_LEQ1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right )) :: (_,(_,T_TYPEleft as T_TYPE1left,T_TYPEright as T_TYPE1right )) :: rest671) => let val result = MlyValue.start (((Type_Assumption(id,tp)))) in (LrTable.NT 0,(result,T_TYPE1left,tp1right),rest671) end | (3,(_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right )) :: (_,(_,T_LEQleft as T_LEQ1left,T_LEQright as T_LEQ1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right )) :: rest671) => let val result = MlyValue.start (((Type_Assumption(id,tp)))) in (LrTable.NT 0,(result,id1left,tp1right),rest671) end | (4,(_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right )) :: (_,(_,T_DOUBLEEQleft as T_DOUBLEEQ1left,T_DOUBLEEQright as T_DOUBLEEQ1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left, idright as id1right)) :: (_,(_,T_TYPEleft as T_TYPE1left, T_TYPEright as T_TYPE1right)) :: rest671) => let val result = MlyValue.start (((Type_Abbrev(id,tp)))) in (LrTable.NT 0,(result,T_TYPE1left,tp1right),rest671) end | (5,(_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right )) :: (_,(_,T_DOUBLEEQleft as T_DOUBLEEQ1left,T_DOUBLEEQright as T_DOUBLEEQ1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left, idright as id1right)) :: rest671) => let val result = MlyValue.start (((Type_Abbrev(id,tp)))) in (LrTable.NT 0,(result,id1left,tp1right),rest671) end | (6,(_,(MlyValue.term (term1 as term),termleft as term1left, termright as term1right)) :: (_,(_,T_EQleft as T_EQ1left,T_EQright as T_EQ1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left, idright as id1right)) :: rest671) => let val result = MlyValue.start (((Term_Def(id,term)))) in (LrTable.NT 0,(result,id1left,term1right),rest671) end | (7,(_,(MlyValue.term (term1 as term),termleft as term1left, termright as term1right)) :: rest671) => let val result = MlyValue.start (((Term_Def(Id.intern "it",term)))) in (LrTable.NT 0,(result,term1left,term1right),rest671) end | (8,(_,(_,T_EOFleft as T_EOF1left,T_EOFright as T_EOF1right)) :: rest671) => let val result = MlyValue.start (((Nothing))) in (LrTable.NT 0,(result,T_EOF1left,T_EOF1right),rest671) end | (9,(_,(MlyValue.setcmd (setcmd1 as setcmd),setcmdleft as setcmd1left ,setcmdright as setcmd1right)) :: rest671) => let val result = MlyValue.start (((setcmd))) in (LrTable.NT 0,(result,setcmd1left,setcmd1right),rest671) end | (10,(_,(MlyValue.T_ID (T_ID1 as T_ID),T_IDleft as T_ID1left, T_IDright as T_ID1right)) :: (_,(_,T_SETleft as T_SET1left, T_SETright as T_SET1right)) :: rest671) => let val result = MlyValue.setcmd (((Set(T_ID,"true")))) in (LrTable.NT 1,(result,T_SET1left,T_ID1right),rest671) end | (11,(_,(MlyValue.T_ID (T_ID1 as T_ID),T_IDleft as T_ID1left, T_IDright as T_ID1right)) :: (_,(_,T_DEBUGleft as T_DEBUG1left, T_DEBUGright as T_DEBUG1right)) :: rest671) => let val result = MlyValue.setcmd (((Set(T_ID,"true")))) in (LrTable.NT 1,(result,T_DEBUG1left,T_ID1right),rest671) end | (12,(_,(MlyValue.T_ID (T_ID1 as T_ID),T_IDleft as T_ID1left, T_IDright as T_ID1right)) :: (_,(_,T_RESETleft as T_RESET1left, T_RESETright as T_RESET1right)) :: rest671) => let val result = MlyValue.setcmd (((Set(T_ID,"false")))) in (LrTable.NT 1,(result,T_RESET1left,T_ID1right),rest671) end | (13,(_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: rest671) => let val result = MlyValue.tp (((PRETVAR(id)))) in (LrTable.NT 5,(result,id1left,id1right),rest671) end | (14,(_,(MlyValue.tp (tp2),tp2left,tp2right)) :: (_,(_, T_ARROWleft as T_ARROW1left,T_ARROWright as T_ARROW1right)) :: (_,( MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right)) :: rest671) => let val result = MlyValue.tp (((PREARROW(tp1,tp2)))) in (LrTable.NT 5,(result,tp1left,tp2right),rest671) end | (15,(_,(MlyValue.tp (tp2),tp2left,tp2right)) :: (_,(_, T_INTERleft as T_INTER1left,T_INTERright as T_INTER1right)) :: (_,( MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right)) :: rest671) => let val result = MlyValue.tp (((PREMEET([tp1,tp2])))) in (LrTable.NT 5,(result,tp1left,tp2right),rest671) end | (16,(_,(_,T_RBRACKleft as T_RBRACK1left,T_RBRACKright as T_RBRACK1right)) :: (_,(MlyValue.tplist (tplist1 as tplist), tplistleft as tplist1left,tplistright as tplist1right)) :: (_,(_, T_LBRACKleft as T_LBRACK1left,T_LBRACKright as T_LBRACK1right)) :: (_,(_,T_INTERleft as T_INTER1left,T_INTERright as T_INTER1right)) :: rest671) => let val result = MlyValue.tp (((PREMEET(tplist)))) in (LrTable.NT 5,(result,T_INTER1left,T_RBRACK1right),rest671) end | (17,(_,(_,T_NSleft as T_NS1left,T_NSright as T_NS1right)) :: rest671) => let val result = MlyValue.tp (((PREMEET([])))) in (LrTable.NT 5,(result,T_NS1left,T_NS1right),rest671) end | (18,(_,(_,T_RPARENleft as T_RPAREN1left,T_RPARENright as T_RPAREN1right)) :: (_,(MlyValue.tp (tp1 as tp),tpleft as tp1left, tpright as tp1right)) :: (_,(_,T_LPARENleft as T_LPAREN1left, T_LPARENright as T_LPAREN1right)) :: rest671) => let val result = MlyValue.tp (((tp))) in (LrTable.NT 5,(result,T_LPAREN1left,T_RPAREN1right),rest671) end | (19,(_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right)) :: (_,(_,T_DOTleft as T_DOT1left,T_DOTright as T_DOT1right )) :: (_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: (_,(_,T_ALLleft as T_ALL1left,T_ALLright as T_ALL1right )) :: rest671) => let val result = MlyValue.tp (((PREALL(id, PREMEET[], tp)))) in (LrTable.NT 5,(result,T_ALL1left,tp1right),rest671) end | (20,(_,(MlyValue.tp (tp2),tp2left,tp2right)) :: (_,(_,T_DOTleft as T_DOT1left,T_DOTright as T_DOT1right)) :: (_,(MlyValue.tp (tp1 as tp), tpleft as tp1left,tpright as tp1right)) :: (_,(_,T_LEQleft as T_LEQ1left,T_LEQright as T_LEQ1right)) :: (_,(MlyValue.id (id1 as id), idleft as id1left,idright as id1right)) :: (_,(_,T_ALLleft as T_ALL1left,T_ALLright as T_ALL1right)) :: rest671) => let val result = MlyValue.tp (((PREALL(id, tp1, tp2)))) in (LrTable.NT 5,(result,T_ALL1left,tp2right),rest671) end | (21,(_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right)) :: (_,(_,T_DOTleft as T_DOT1left,T_DOTright as T_DOT1right )) :: (_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: (_,(_,T_SOMEleft as T_SOME1left,T_SOMEright as T_SOME1right)) :: rest671) => let val result = MlyValue.tp ((( let val b = Id.new() val bv = PRETVAR(b) val idv = PRETVAR(id) in PREALL(b,PREMEET[], PREARROW(PREALL(id, PREMEET[], PREARROW(tp, bv)), bv)) end ))) in (LrTable.NT 5,(result,T_SOME1left,tp1right),rest671) end | (22,(_,(MlyValue.tp (tp2),tp2left,tp2right)) :: (_,(_,T_DOTleft as T_DOT1left,T_DOTright as T_DOT1right)) :: (_,(MlyValue.tp (tp1 as tp), tpleft as tp1left,tpright as tp1right)) :: (_,(_,T_LEQleft as T_LEQ1left,T_LEQright as T_LEQ1right)) :: (_,(MlyValue.id (id1 as id), idleft as id1left,idright as id1right)) :: (_,(_,T_SOMEleft as T_SOME1left,T_SOMEright as T_SOME1right)) :: rest671) => let val result = MlyValue.tp ((( let val b = Id.new() val bv = PRETVAR(b) val idv = PRETVAR(id) in PREALL(b,PREMEET[], PREARROW(PREALL(id, tp1, PREARROW(tp2, bv)), bv)) end ))) in (LrTable.NT 5,(result,T_SOME1left,tp2right),rest671) end | (23,(_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right)) :: rest671) => let val result = MlyValue.tplist ((([tp]))) in (LrTable.NT 6,(result,tp1left,tp1right),rest671) end | (24,(_,(MlyValue.tplist (tplist1 as tplist),tplistleft as tplist1left,tplistright as tplist1right)) :: (_,(_,T_COMMAleft as T_COMMA1left,T_COMMAright as T_COMMA1right)) :: (_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right)) :: rest671) => let val result = MlyValue.tplist (((tp::tplist))) in (LrTable.NT 6,(result,tp1left,tplist1right),rest671) end | (25,(_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: rest671) => let val result = MlyValue.idlist ((([id]))) in (LrTable.NT 3,(result,id1left,id1right),rest671) end | (26,(_,(MlyValue.idlist (idlist1 as idlist),idlistleft as idlist1left,idlistright as idlist1right)) :: (_,(_,T_COMMAleft as T_COMMA1left,T_COMMAright as T_COMMA1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: rest671) => let val result = MlyValue.idlist (((id::idlist))) in (LrTable.NT 3,(result,id1left,idlist1right),rest671) end | (27,(_,(MlyValue.T_ID (T_ID1 as T_ID),T_IDleft as T_ID1left, T_IDright as T_ID1right)) :: rest671) => let val result = MlyValue.id (((Id.intern T_ID))) in (LrTable.NT 2,(result,T_ID1left,T_ID1right),rest671) end | (28,(_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: rest671) => let val result = MlyValue.const (((id))) in (LrTable.NT 4,(result,id1left,id1right),rest671) end | (29,(_,(MlyValue.T_INT_CONST (T_INT_CONST1 as T_INT_CONST), T_INT_CONSTleft as T_INT_CONST1left,T_INT_CONSTright as T_INT_CONST1right)) :: rest671) => let val result = MlyValue.const (((Id.intern T_INT_CONST))) in (LrTable.NT 4,(result,T_INT_CONST1left,T_INT_CONST1right),rest671) end | (30,(_,(MlyValue.T_STR_CONST (T_STR_CONST1 as T_STR_CONST), T_STR_CONSTleft as T_STR_CONST1left,T_STR_CONSTright as T_STR_CONST1right)) :: rest671) => let val result = MlyValue.const (((Id.intern T_STR_CONST))) in (LrTable.NT 4,(result,T_STR_CONST1left,T_STR_CONST1right),rest671) end | (31,(_,(MlyValue.appl (appl1 as appl),applleft as appl1left, applright as appl1right)) :: rest671) => let val result = MlyValue.term (((appl))) in (LrTable.NT 7,(result,appl1left,appl1right),rest671) end | (32,(_,(MlyValue.bnd (bnd1 as bnd),bndleft as bnd1left,bndright as bnd1right)) :: rest671) => let val result = MlyValue.term (((bnd))) in (LrTable.NT 7,(result,bnd1left,bnd1right),rest671) end | (33,(_,(MlyValue.term (term1 as term),termleft as term1left, termright as term1right)) :: (_,(_,T_DOTleft as T_DOT1left, T_DOTright as T_DOT1right)) :: (_,(MlyValue.tplist (tplist1 as tplist) ,tplistleft as tplist1left,tplistright as tplist1right)) :: (_,(_, T_COLONleft as T_COLON1left,T_COLONright as T_COLON1right)) :: (_,( MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: (_,(_,T_LAMBDAleft as T_LAMBDA1left,T_LAMBDAright as T_LAMBDA1right )) :: rest671) => let val result = MlyValue.bnd ((( case tplist of [t] => PREABS(id,t,term) | ts => let val a = Id.new_from id in PREFOR(a,ts, PREABS(id,PRETVAR(a),term)) end ))) in (LrTable.NT 9,(result,T_LAMBDA1left,term1right),rest671) end | (34,(_,(MlyValue.term (term1 as term),termleft as term1left, termright as term1right)) :: (_,(_,T_DOTleft as T_DOT1left, T_DOTright as T_DOT1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: (_,(_,T_BIGLAMBDAleft as T_BIGLAMBDA1left,T_BIGLAMBDAright as T_BIGLAMBDA1right)) :: rest671) => let val result = MlyValue.bnd (((PRETABS(id,PREMEET[],term)))) in (LrTable.NT 9,(result,T_BIGLAMBDA1left,term1right),rest671) end | (35,(_,(MlyValue.term (term1 as term),termleft as term1left, termright as term1right)) :: (_,(_,T_DOTleft as T_DOT1left, T_DOTright as T_DOT1right)) :: (_,(MlyValue.tp (tp1 as tp),tpleft as tp1left,tpright as tp1right)) :: (_,(_,T_LEQleft as T_LEQ1left, T_LEQright as T_LEQ1right)) :: (_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: (_,(_,T_BIGLAMBDAleft as T_BIGLAMBDA1left,T_BIGLAMBDAright as T_BIGLAMBDA1right)) :: rest671) => let val result = MlyValue.bnd (((PRETABS(id,tp,term)))) in (LrTable.NT 9,(result,T_BIGLAMBDA1left,term1right),rest671) end | (36,(_,(MlyValue.term (term1 as term),termleft as term1left, termright as term1right)) :: (_,(_,T_DOTleft as T_DOT1left, T_DOTright as T_DOT1right)) :: (_,(MlyValue.tplist (tplist1 as tplist) ,tplistleft as tplist1left,tplistright as tplist1right)) :: (_,(_, T_INleft as T_IN1left,T_INright as T_IN1right)) :: (_,(MlyValue.idlist (idlist1 as idlist),idlistleft as idlist1left,idlistright as idlist1right)) :: (_,(_,T_BIGLAMBDAleft as T_BIGLAMBDA1left, T_BIGLAMBDAright as T_BIGLAMBDA1right)) :: rest671) => let val result = MlyValue.bnd ((( let fun f [] = term | f (v::vs) = PREFOR(v, tplist, f vs) in f idlist end ))) in (LrTable.NT 9,(result,T_BIGLAMBDA1left,term1right),rest671) end | (37,(_,(MlyValue.term (term1 as term),termleft as term1left, termright as term1right)) :: (_,(_,T_DOTleft as T_DOT1left, T_DOTright as T_DOT1right)) :: (_,(MlyValue.tplist (tplist1 as tplist) ,tplistleft as tplist1left,tplistright as tplist1right)) :: (_,(_, T_INleft as T_IN1left,T_INright as T_IN1right)) :: (_,(MlyValue.idlist (idlist1 as idlist),idlistleft as idlist1left,idlistright as idlist1right)) :: (_,(_,T_FORleft as T_FOR1left,T_FORright as T_FOR1right)) :: rest671) => let val result = MlyValue.bnd ((( let fun f [] = term | f (v::vs) = PREFOR(v, tplist, f vs) in f idlist end ))) in (LrTable.NT 9,(result,T_FOR1left,term1right),rest671) end | (38,(_,(MlyValue.const (const1 as const),constleft as const1left, constright as const1right)) :: rest671) => let val result = MlyValue.appl (((PREVAR(const)))) in (LrTable.NT 8,(result,const1left,const1right),rest671) end | (39,(_,(_,T_RPARENleft as T_RPAREN1left,T_RPARENright as T_RPAREN1right)) :: (_,(MlyValue.term (term1 as term),termleft as term1left,termright as term1right)) :: (_,(_,T_LPARENleft as T_LPAREN1left,T_LPARENright as T_LPAREN1right)) :: rest671) => let val result = MlyValue.appl (((term))) in (LrTable.NT 8,(result,T_LPAREN1left,T_RPAREN1right),rest671) end | (40,(_,(MlyValue.id (id1 as id),idleft as id1left,idright as id1right)) :: (_,(MlyValue.appl (appl1 as appl),applleft as appl1left, applright as appl1right)) :: rest671) => let val result = MlyValue.appl (((PREAPP(appl,PREVAR(id))))) in (LrTable.NT 8,(result,appl1left,id1right),rest671) end | (41,(_,(_,T_RPARENleft as T_RPAREN1left,T_RPARENright as T_RPAREN1right)) :: (_,(MlyValue.term (term1 as term),termleft as term1left,termright as term1right)) :: (_,(_,T_LPARENleft as T_LPAREN1left,T_LPARENright as T_LPAREN1right)) :: (_,(MlyValue.appl ( appl1 as appl),applleft as appl1left,applright as appl1right)) :: rest671) => let val result = MlyValue.appl (((PREAPP(appl,term)))) in (LrTable.NT 8,(result,appl1left,T_RPAREN1right),rest671) end | (42,(_,(_,T_RBRACKleft as T_RBRACK1left,T_RBRACKright as T_RBRACK1right)) :: (_,(MlyValue.tp (tp1 as tp),tpleft as tp1left, tpright as tp1right)) :: (_,(_,T_LBRACKleft as T_LBRACK1left, T_LBRACKright as T_LBRACK1right)) :: (_,(MlyValue.appl (appl1 as appl) ,applleft as appl1left,applright as appl1right)) :: rest671) => let val result = MlyValue.appl (((PRETAPP(appl,tp)))) in (LrTable.NT 8,(result,appl1left,T_RBRACK1right),rest671) end | _ => raise (mlyAction i392) end val void = MlyValue.VOID val extract = fn a => (fn MlyValue.start x => x | _ => let exception ParseInternal in raise ParseInternal end) a end end structure Tokens : FMEET_TOKENS = struct type svalue = ParserData.svalue type ('a,'b) token = ('a,'b) Token.token fun T_EOF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 0,( ParserData.MlyValue.VOID,p1,p2)) fun T_DOT (p1,p2) = Token.TOKEN (ParserData.LrTable.T 1,( ParserData.MlyValue.VOID,p1,p2)) fun T_COLON (p1,p2) = Token.TOKEN (ParserData.LrTable.T 2,( ParserData.MlyValue.VOID,p1,p2)) fun T_SEMICOLON (p1,p2) = Token.TOKEN (ParserData.LrTable.T 3,( ParserData.MlyValue.VOID,p1,p2)) fun T_LEQ (p1,p2) = Token.TOKEN (ParserData.LrTable.T 4,( ParserData.MlyValue.VOID,p1,p2)) fun T_COMMA (p1,p2) = Token.TOKEN (ParserData.LrTable.T 5,( ParserData.MlyValue.VOID,p1,p2)) fun T_APOST (p1,p2) = Token.TOKEN (ParserData.LrTable.T 6,( ParserData.MlyValue.VOID,p1,p2)) fun T_EQ (p1,p2) = Token.TOKEN (ParserData.LrTable.T 7,( ParserData.MlyValue.VOID,p1,p2)) fun T_DOUBLEEQ (p1,p2) = Token.TOKEN (ParserData.LrTable.T 8,( ParserData.MlyValue.VOID,p1,p2)) fun T_DOLLAR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 9,( ParserData.MlyValue.VOID,p1,p2)) fun T_AT (p1,p2) = Token.TOKEN (ParserData.LrTable.T 10,( ParserData.MlyValue.VOID,p1,p2)) fun T_ARROW (p1,p2) = Token.TOKEN (ParserData.LrTable.T 11,( ParserData.MlyValue.VOID,p1,p2)) fun T_DARROW (p1,p2) = Token.TOKEN (ParserData.LrTable.T 12,( ParserData.MlyValue.VOID,p1,p2)) fun T_LPAREN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 13,( ParserData.MlyValue.VOID,p1,p2)) fun T_RPAREN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 14,( ParserData.MlyValue.VOID,p1,p2)) fun T_LBRACK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 15,( ParserData.MlyValue.VOID,p1,p2)) fun T_RBRACK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 16,( ParserData.MlyValue.VOID,p1,p2)) fun T_LANGLE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 17,( ParserData.MlyValue.VOID,p1,p2)) fun T_RANGLE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 18,( ParserData.MlyValue.VOID,p1,p2)) fun T_LCURLY (p1,p2) = Token.TOKEN (ParserData.LrTable.T 19,( ParserData.MlyValue.VOID,p1,p2)) fun T_RCURLY (p1,p2) = Token.TOKEN (ParserData.LrTable.T 20,( ParserData.MlyValue.VOID,p1,p2)) fun T_INTER (p1,p2) = Token.TOKEN (ParserData.LrTable.T 21,( ParserData.MlyValue.VOID,p1,p2)) fun T_LAMBDA (p1,p2) = Token.TOKEN (ParserData.LrTable.T 22,( ParserData.MlyValue.VOID,p1,p2)) fun T_BIGLAMBDA (p1,p2) = Token.TOKEN (ParserData.LrTable.T 23,( ParserData.MlyValue.VOID,p1,p2)) fun T_ID (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 24,( ParserData.MlyValue.T_ID i,p1,p2)) fun T_INT_CONST (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 25,( ParserData.MlyValue.T_INT_CONST i,p1,p2)) fun T_STR_CONST (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 26,( ParserData.MlyValue.T_STR_CONST i,p1,p2)) fun T_USE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 27,( ParserData.MlyValue.VOID,p1,p2)) fun T_TYPE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 28,( ParserData.MlyValue.VOID,p1,p2)) fun T_SET (p1,p2) = Token.TOKEN (ParserData.LrTable.T 29,( ParserData.MlyValue.VOID,p1,p2)) fun T_RESET (p1,p2) = Token.TOKEN (ParserData.LrTable.T 30,( ParserData.MlyValue.VOID,p1,p2)) fun T_DEBUG (p1,p2) = Token.TOKEN (ParserData.LrTable.T 31,( ParserData.MlyValue.VOID,p1,p2)) fun T_CHECK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 32,( ParserData.MlyValue.VOID,p1,p2)) fun T_WITH (p1,p2) = Token.TOKEN (ParserData.LrTable.T 33,( ParserData.MlyValue.VOID,p1,p2)) fun T_ALL (p1,p2) = Token.TOKEN (ParserData.LrTable.T 34,( ParserData.MlyValue.VOID,p1,p2)) fun T_IN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 35,( ParserData.MlyValue.VOID,p1,p2)) fun T_NS (p1,p2) = Token.TOKEN (ParserData.LrTable.T 36,( ParserData.MlyValue.VOID,p1,p2)) fun T_CASE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 37,( ParserData.MlyValue.VOID,p1,p2)) fun T_OF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 38,( ParserData.MlyValue.VOID,p1,p2)) fun T_FOR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 39,( ParserData.MlyValue.VOID,p1,p2)) fun T_OBSERVE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 40,( ParserData.MlyValue.VOID,p1,p2)) fun T_INSTALL (p1,p2) = Token.TOKEN (ParserData.LrTable.T 41,( ParserData.MlyValue.VOID,p1,p2)) fun T_SOME (p1,p2) = Token.TOKEN (ParserData.LrTable.T 42,( ParserData.MlyValue.VOID,p1,p2)) fun T_OPEN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 43,( ParserData.MlyValue.VOID,p1,p2)) fun T_END (p1,p2) = Token.TOKEN (ParserData.LrTable.T 44,( ParserData.MlyValue.VOID,p1,p2)) fun T_PACK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 45,( ParserData.MlyValue.VOID,p1,p2)) end end signature FILEUTILS = sig val open_fmeet_file: string -> (instream * string) end functor Main( structure Globals: GLOBALS structure Typ: TYP structure Trm: TRM structure FileUtils: FILEUTILS structure Parse: PARSE structure Leq: LEQ structure Synth: SYNTH sharing Typ.Globals = Globals and Parse.ParseRes.Typ = Typ and Parse.ParseRes.Trm = Trm and Leq.Typ = Typ and Trm.Typ = Typ and Synth.Trm = Trm and Synth.Leq = Leq val buildtime : string ) = struct open Globals; open Parse.ParseRes; val global_tenv = ref(Typ.empty_tenv) exception NotABoolean fun string_to_bool "true" = true | string_to_bool "True" = true | string_to_bool "TRUE" = true | string_to_bool "t" = true | string_to_bool "T" = true | string_to_bool "yes" = true | string_to_bool "Yes" = true | string_to_bool "YES" = true | string_to_bool "false" = false | string_to_bool "False" = false | string_to_bool "FALSE" = false | string_to_bool "f" = false | string_to_bool "F" = false | string_to_bool "no" = false | string_to_bool "No" = false | string_to_bool "NO" = false | string_to_bool _ = raise NotABoolean fun rep_loop done parser error = while (not (done())) do (case parser() of Use(f) => rep_loop_on_file f | Type_Assumption(i,pt) => let val t = Typ.debruijnify (!global_tenv) pt in write (Id.tostr i); write " <= "; Typ.prt (stdpp()) (!global_tenv) t; write "\n"; global_tenv := Typ.push_bound (!global_tenv) i t end | Type_Abbrev(i,pt) => let val t = Typ.debruijnify (!global_tenv) pt val _ = global_tenv := Typ.push_abbrev (!global_tenv) i t in write (Id.tostr i); write " == "; Typ.prt (stdpp()) (!global_tenv) t; write "\n" end | Term_Def(i,ptrm) => let val trm = Trm.debruijnify (!global_tenv) ptrm val typ = Synth.synth (!global_tenv) trm in write (Id.tostr i); write " = "; Pp.setb (stdpp()); Trm.prt (stdpp()) (!global_tenv) trm; Pp.break (stdpp()) true ~3; write " : "; Typ.prt (stdpp()) (!global_tenv) typ; Pp.break (stdpp()) true ~3; (* write " in "; Typ.prt_tenv (stdpp()) (Typ.pop (!global_tenv)); *) Pp.endb (stdpp()); write "\n"; global_tenv := Typ.push_binding (!global_tenv) i typ end | Leq(pt1,pt2) => let val t1 = Typ.debruijnify (!global_tenv) pt1 val t2 = Typ.debruijnify (!global_tenv) pt2 in if Leq.leq (!global_tenv) t1 t2 then write "Yes\n" else write "No\n" end | Nothing => () | Set(name,v) => (set_flag name (string_to_bool v)) | _ => write "Unimplemented ParseResult!\n" ) handle Typ.WrongKindOfId(te,i,which) => (write ("Wrong kind of identifier: "^ (makestring i) ^" (" ^ which ^ " expected)\nin "); Typ.prt_tenv (stdpp()) te; error()) | unknown => (write ("Exception: "^(System.exn_name unknown)^"\n"); error()) and rep_loop_on_file fname = let val (dev,real_name) = FileUtils.open_fmeet_file fname val quit = ref false fun parser() = Parse.stream_parse dev fun done() = (!quit) orelse (end_of_stream dev) fun error() = (quit := true); in write ("Reading from \"" ^ real_name ^ "\"...\n\n"); (rep_loop done parser error; write ("\nClosing " ^ real_name ^ "\n"); close_in dev) handle Io(s) => write ("IO error on " ^ fname ^ ": " ^ s ^ "\n") end fun top() = let fun top_done () = (print "> "; flush_out std_out; end_of_stream(std_in)) fun top_error () = () in write ("Welcome to FMEET (" ^ buildtime ^ ")...\n\n"); rep_loop top_done Parse.top_parse top_error; write "\n" end val read_from_file = ref ""; fun parse_switches ("-i"::s::rest) = (read_from_file := s; parse_switches rest) | parse_switches (s::rest) = (read_from_file := s; parse_switches rest) | parse_switches ([]) = () fun rep_command_line(argv,env) = (parse_switches (tl argv); if (!read_from_file) = "" then top() else rep_loop_on_file (!read_from_file) ) fun process_file s = rep_command_line (["",s^".fm"],nil); end functor WrMgt( structure Wr: WR structure Pp: PP sharing Pp.Wr = Wr ) : WRMGT = struct structure Wr = Wr; structure Pp = Pp; val current_underlying_wr = ref(Wr.to_stdout()); val current_pp = ref(Pp.pp_from_wr (!current_underlying_wr)); val current_wr = ref(Pp.wr_from_pp (!current_pp)); fun stdpp() = !current_pp; fun get_current_wr() = !current_wr; fun set_current_wr wr = (current_underlying_wr := wr; current_pp := Pp.pp_from_wr (!current_underlying_wr); current_wr := Pp.wr_from_pp (!current_pp)) fun write s = Pp.pwrite (!current_pp) s; end functor Id (structure SymTab: HASH structure InvSymTab: TABLE sharing type SymTab.elem = string and type InvSymTab.key = int ) : ID = struct val symtab = ref SymTab.empty; val invsymtab = ref (InvSymTab.empty: string InvSymTab.table); val DEBUG = ref false; type T = int exception CantHappen fun intern (s:string) = let val _ = if not (SymTab.exists(s,!symtab)) then symtab := SymTab.add(s, (!symtab)) else () val i_opt = SymTab.find (s, (!symtab)) in case i_opt of NONE => raise CantHappen | SOME(i) => (invsymtab := InvSymTab.insert((i,s), (!invsymtab)); i) end fun hashcode i = i exception UnknownId fun tostr (i:T) : string = let val s_opt = InvSymTab.find (i, (!invsymtab)) in case s_opt of NONE => raise UnknownId | SOME(s) => s end val newvarcount = ref 0; fun reset_new_counter() = (newvarcount := 0) fun new_from i = let val _ = newvarcount := !newvarcount + 1 val name = (tostr i) ^ "_" ^ (makestring (!newvarcount)) in if SymTab.exists(name,!symtab) then new_from i else intern name end val id_x = intern "x" fun new() = new_from id_x fun == (i:T) (i':T) = (i = i') fun lexlt (i:T) (i':T) = ((tostr i) < (tostr i')) end functor FileUtils(): FILEUTILS = struct fun open_fmeet_file fname = (open_in fname,fname) handle Io(s) => (open_in (fname ^ ".fm"), fname ^ ".fm") handle Io(s) => (open_in ("examples/" ^ fname), "examples/" ^ fname) handle Io(s) => (open_in ("examples/" ^ fname ^ ".fm"), "examples/" ^ fname ^ ".fm") handle Io(s) => raise Io(fname ^ " not found") end functor ParseRes (structure Typ: TYP structure Trm: TRM structure Globals: GLOBALS sharing Typ.Globals = Globals and Trm.Typ = Typ ) : PARSERES = struct structure Typ = Typ structure Trm = Trm structure Globals = Globals datatype T = Leq of Typ.pretyp * Typ.pretyp | Type_Assumption of Globals.Id.T * Typ.pretyp | Type_Abbrev of Globals.Id.T * Typ.pretyp | Term_Def of Globals.Id.T * Trm.pretrm | Term_Assumption of Globals.Id.T * Typ.pretyp | Use of string | Set of string * string | Nothing end (* ----------------------------------------------------------------------- *) (* *) (* Low-level prettyprinting stream package. Based on notes by Greg Nelson *) (* *) (* ----------------------------------------------------------------------- *) functor Pp (structure Wr: WR) : PP = struct structure Wr = Wr (* ----------------------------------------------------------------------- *) (* Utilities *) (* ----------------------------------------------------------------------- *) val DEBUG = ref false; fun debug ss = if (!DEBUG) then print ((implode ss) ^ "\n") else () fun mapunit f = let fun m ([]) = () | m (hd::tl) = ((f hd); m tl) in m end (* ----------------------------------------------------------------------- *) (* Data Structures *) (* ----------------------------------------------------------------------- *) datatype BreakBehavior = NLINDENT of int | EXPLICIT of string datatype Token = CHAR of int | SETB | ENDB | BREAK of {united:bool, do_what:BreakBehavior} | LONG of string datatype RefList = NIL | CONS of Token * (RefList ref) exception CalledErrorCont val error_cont : unit cont = callcc (fn k => (callcc (fn ek => throw k ek); raise CalledErrorCont)) exception CoroutineBug exception PPQueueOverflowed type Pp = {wr:Wr.Wr, q: Token array, qr: int ref, inp: int ref, m1: int ref, m2: int ref, m3: int ref, outq: Token array, outp: int ref, indent: int ref, margin: int ref, empty: unit cont ref, nonempty: unit cont ref} val qlen = 500; val outqlen = 500; val default_margin = 76; fun init_pp (wr:Wr.Wr) : Pp = {wr = wr, q = array(qlen, CHAR(33)), qr = ref 0, inp = ref 0, m1 = ref 0, m2 = ref 0, m3 = ref 0, outq = array(outqlen, CHAR(33)), outp = ref 0, indent = ref 0, margin = ref default_margin, empty = ref(error_cont), nonempty = ref(error_cont)} fun enqueue (pp:Pp) tok = let val {q=q, qr=qr, inp=inp, m1=m1, empty=empty, nonempty=nonempty, ...} = pp val curqr = !qr val _ = debug ["enqueue: "," qr=",makestring (!qr), " inp=",makestring (!inp), " m1=",makestring (!m1)] in debug ["enqueue"]; if ((curqr+1) mod qlen = (!inp)) orelse ((curqr+1) mod qlen = (!m1)) then raise PPQueueOverflowed else (); update(q, curqr, tok); qr := (curqr + 1) mod qlen; debug ["enqueue: about to switch"]; callcc (fn k => (empty := k; throw (!nonempty) ())); debug ["enqueue: returning"] end fun requeue (pp:Pp) = let val {q=q, qr=qr, inp=inp, empty=empty, nonempty=nonempty, m1=m1, ...} = pp val _ = debug ["requeue: "," qr=",makestring (!qr), " inp=",makestring (!inp), " m1=",makestring (!m1)] in inp := ((!inp) - 1) mod qlen end fun dequeue (pp:Pp) = let val {q=q, qr=qr, inp=inp, empty=empty, nonempty=nonempty, m1=m1, ...} = pp val _ = debug ["dequeue: "," qr=",makestring (!qr), " inp=",makestring (!inp), " m1=",makestring (!m1)] val _ = (* Front make sure there's something to dequeue *) callcc (fn k => (debug ["dequeue: checking for input"]; if (!inp) = (!qr) then (debug ["dequeue: blocking"]; nonempty := k; throw (!empty) ()) else ())) val _ = debug ["dequeue: unblocked"] val _ = if (!inp)<0 orelse (!inp)>qlen then print ("About to crash: "^(makestring (!inp))^"\n") else () val c = q sub (!inp) val _ = inp := ((!inp) + 1) mod qlen in debug ["dequeue: returning"]; c end (* ----------------------------------------------------------------------- *) (* Processing *) (* ----------------------------------------------------------------------- *) exception LineTooLong exception HowdThatGetInHere fun raw_printline (pp as {wr=wr, outq=outq, outp=outp, ...}:Pp) = let val i = ref 0 in while ((!i)<(!outp)) do (case outq sub (!i) of CHAR(c) => Wr.write_wr wr (chr c) | LONG(s) => Wr.write_wr wr s | _ => raise HowdThatGetInHere; i := (!i)+1) end fun write_tok (pp as {outq=outq, outp=outp, indent=indent, margin=margin, ...}:Pp) c raiseok = let in update (outq,!outp,c); if (!outp) < outqlen then outp := (!outp)+1 else (); case c of CHAR(10) => (raw_printline pp; indent := 0; outp := 0) | _ => (indent := (!indent)+1; if (!indent) > (!margin) andalso raiseok then raise LineTooLong else ()) end fun do_break pp indent (NLINDENT(n)) = let val i = ref 0 in write_tok pp (CHAR(10)) true; while ((!i) enqueue pp (CHAR(ord s))) (explode s) fun P1 pp = let fun loop() = (debug ["P1_loop"]; case dequeue pp of (c as CHAR(_)) => (write_tok pp c true; loop()) | (c as LONG(_)) => (write_tok pp c true; loop()) | SETB => (P1 pp; loop()) | BREAK(_) => loop() | ENDB => ()) in debug ["P1"]; loop(); debug ["P1: finished"] end and P2 pp = let fun loop() = (debug ["P2_loop"]; case dequeue pp of (c as CHAR(_)) => (write_tok pp c true; loop()) | (c as LONG(_)) => (write_tok pp c true; loop()) | SETB => (P1 pp; loop()) | BREAK(_) => () | ENDB => ()) in debug ["P2"]; loop(); (* I think the input queue needs to be backed up by one now, so that P3 sees this SETB or BREAK... *) requeue pp; debug ["P2: finished"] end and P3 (pp as {inp=inp, outp=outp, indent=indent, m1=m1, m2=m2, m3=m3, ...} :Pp) = let val saved_indent = !indent fun loop() = (debug ["P3_loop"]; case dequeue pp of (c as CHAR(_)) => (write_tok pp c false; loop()) | (c as LONG(_)) => (write_tok pp c false; loop()) | SETB => (PP pp; loop()) | BREAK({united=true,do_what=do_what}) => (do_break pp saved_indent do_what; m1 := ~1; (* Not in CGN's original note *) loop()) | BREAK({united=false,do_what=do_what}) => (m1 := (!inp); m2 := (!outp); m3 := (!indent); ((P2 pp; m1 := ~1; (* This once seemed wrong *) debug ["P3: looping back"]; loop()) handle LineTooLong => (debug ["P3: line too long"]; inp := (!m1); outp := (!m2); indent := (!m3); do_break pp saved_indent do_what; m1 := ~1; loop()))) | ENDB => ()) in debug ["P3"]; loop() end and PP (pp as {inp=inp, outp=outp, indent=indent, m1=m1, m2=m2, m3=m3, ...} :Pp) = let in debug ["PP"]; m1 := (!inp); m2 := (!outp); m3 := (!indent); (P1 pp; m1 := ~1; debug ["PP finished"]) handle LineTooLong => (debug ["PP: line too long"]; inp := (!m1); outp := (!m2); indent := (!m3); m1 := ~1; P3 pp) end exception EndbWithNoMatchingSetb fun top_level pp = let in debug ["top_level"]; P3 pp; raise EndbWithNoMatchingSetb end (* ----------------------------------------------------------------------- *) (* Interaction *) (* ----------------------------------------------------------------------- *) fun setb pp = enqueue pp SETB fun endb pp = enqueue pp ENDB fun break pp b i = enqueue pp (BREAK {united=b, do_what=(NLINDENT i)}) fun expbreak pp b s = enqueue pp (BREAK {united=b, do_what=(EXPLICIT s)}) fun pwrite (pp as {wr=wr, ...} : Pp) s = (debug ["write: '", s, "'"]; mapunit (fn s => case ord(s) of 10 => break pp true 0 | i => enqueue pp (CHAR(i))) (explode s)) exception IllegalMargin fun set_margin (pp as {margin=margin, outp=outp , ...} : Pp) n = if (!outp) > n orelse n >= outqlen then raise IllegalMargin else margin := n (* ----------------------------------------------------------------------- *) (* Creation *) (* ----------------------------------------------------------------------- *) fun pp_from_wr wr = let val _ = debug ["new"]; val (pp as {empty=empty, ...}:Pp) = init_pp wr in callcc (fn k => (empty := k; top_level pp)); pp end fun wr_from_pp (pp as {wr=wr, ...} : Pp) = Wr.to_fn (fn s => pwrite pp s) (fn () => Wr.close wr) end (* Functor Pp *) functor Wr () : WR = struct datatype wr = WR of wr_spc * unit and wr_spc = TO_STDOUT | TO_FILE of string * outstream | TO_WRS of wr list | TO_STRING of string list ref | TO_FN of (string->unit) * (unit->unit) | TO_NOWHERE type Wr = wr fun new spc = WR(spc, ()) fun to_stdout () = new (TO_STDOUT) fun to_file name = let val out = open_out name in new (TO_FILE(name,out)) end fun to_wrs wrs = new (TO_WRS(wrs)) fun to_fn f cl_f = new (TO_FN(f,cl_f)) fun to_string () = new (TO_STRING(ref([]:string list))) fun to_nowhere () = new (TO_NOWHERE) exception Not_a_TOSTRING_Wr fun extract_str (WR(TO_STRING(ss),_)) = implode (rev (!ss)) | extract_str _ = raise Not_a_TOSTRING_Wr fun mapunit f = let fun m ([]) = () | m (hd::tl) = ((f hd); m tl) in m end fun close (WR(spc,gen)) = case spc of TO_STDOUT => () | TO_FILE(name,out) => close_out out | TO_WRS(wrs) => mapunit close wrs | TO_FN(_,cl_f) => cl_f() | TO_STRING(ss) => () | TO_NOWHERE => () fun write_wr (WR(spc,gen)) s = case spc of TO_STDOUT => output(std_out,s) | TO_FILE(_,out) => output(out,s) | TO_WRS(wrs) => mapunit (fn wr => write_wr wr s) wrs | TO_FN(f,_) => f s | TO_STRING(ss) => ss := (s :: (!ss)) | TO_NOWHERE => () end Comment: See tests/bug429.1.sml for shortened example. Status: not a bug --- caused by illegal redundancy from include specs. --------------------------------------------------------------------------- Number: 430 Title: Subscript in lookTycPath Keywords: Submitter: Dave MacQueen Date: 8/3/91 Version: 0.70 Severity: serious Problem: Following code causes $$ lookTycPath 2: [2,0] tyconInContext: [2,0] messages in d70, indicating Subscript has been raised while interpreting a relative type address. Code: signature S2 = sig structure A : sig type t end datatype u = ITEM of A.t end; functor F(X : sig type v end ) = struct type w = X.v end; functor G(Y : S2) = struct structure B = F(struct type v = Y.u end) end; Comments: Problem is bad env passed to redefineCon (typing/functor.sml) during the application of functor F within the body of G. The env for the instantiated body of F is being used to interpret the type of datacon ITEM from the parameter Y: S2. lookTycPath aborts with a Subscript exception, which gets caught by ArrayExt.app in redoTycs. Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 431 Title: ml_writev Keywords: Submitter: Dave Tarditi Date: 7/1/91 Version: 0.69 Severity: minor Problem: The function ml_writev in cfuns.c for version 0.69 appears to have a bug; the reference to callc_v in it should have 1 added to it, since callc_v is a label that points to the tag of a closure, not the closure itself. By the way, callc_v is defined in the header file prim.h. Fix: The diff of the old version with the new version is below. 570d569 < extern int callc_v[]; 577,578c576,577 < MLState->ml_closure = PTR_CtoML(callc_v); < MLState->ml_pc = CODE_ADDR(PTR_CtoML(callc_v)); --- > MLState->ml_closure = PTR_CtoML(callc_v+1); > MLState->ml_pc = CODE_ADDR(PTR_CtoML(callc_v+1)); Status: fixed in 0.74 (or earlier). --------------------------------------------------------------------------- Number: 432 Title: corrupted (shell) environment Keywords: Submitter: Julian Bradfield Date: 7/1/91 Version: 0.66 System: Sparc Problem: NJ SML version 0.66 (running on Sparc) sometimes corrupts its environment: after compiling a piece of code, executed sub-processes get an environment with (apparently) random characters added to environment values. (The specific piece of code is too long to include here; I don't know how general the problem is.) Comment: [dbm] sent mail asking for code to reproduce the problem. This is the same as #342. [Bradfield confirms that problem is fixed in 0.75 in mail sent 12/5/91.] Status: fixed in 0.74 (JHR) --------------------------------------------------------------------------- Number: 433 Title: lexgen bug Keywords: Submitter: Julian Bradfield Date: 7/1/91 Version: 0.66 Problem: In the lexgen.sml distributed with 0.66, there is a bug at line 1047; when outputting the arguments for the "action" function, there should be a test for !UsesTrailingContext . If true, should the third argument just be nil ? Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 434 Title: interactive input Keywords: Submitter: Lawrence Paulson Date: 1/1/91 Version: 0.66 (and later) Problem: I think there's something strange with interactive I/O. Consider the following: fun prs s = output(std_out,s); val pause_tac = Tactic (fn state => (prs"** Press RETURN to continue: "; if input(std_in,1) = "\n" then Sequence.single state else (prs"Goodbye\n"; Sequence.null))); New Jersey ML waits for input and prints the prompt afterwards. The behavior of ML's I/O is not precisely defined, but most languages flush any awaiting output before demanding input. Really, I would like to accept single-character inputs (rather than lines ending with CR) but Standard ML seems to have no suitable primitive! Status: not a bug, but a sensible request --------------------------------------------------------------------------- Number: 435 Title: patrow syntax Keywords: Submitter: Matti Jokinen, moj@utu.fi Date: 7/28/91 Version: 0.69 System: Sun 3 Severity: minor Problem: The compiler fails to accept the following patrow syntax: id:ty as pat Code: fun f {x:int as y} = x; Transcript: - fun f {x:int as y} = x; Error: Compiler bug: patType -- unexpected pattern Comments: The following patterns are translated correctly: {x = x:int as y} {x as y} {x:int} I think the bug is caused by a missing branch is in the patType function (lines 128-194 in src/typing/typecheck.sml). The parser appears to transform `id:ty as pat' into LAYEREDpat(CONSTAINTpat(_,ty),pat), which is not recognized by patType. Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 436 Title: debugger type checking Keywords: Submitter: Sergio Antoy, antoy@cs.pdx.edu Date: 7/1/91 Version: 0.66 System: Sparc IPC, SunOS 4.1.1 Problem: the debugger reports tycon mismatch on a correct program Code: (* dec (x,l) is the string decimal representation of x over l characters, right justified. If l characters are not enough, then l "*" are returned. If l <= 0, then an exception is raised. *) exception wrong_field_size fun dec (x, l) = if l <= 0 then raise wrong_field_size else let fun dok (0, "") = "0" | dok (0, s) = s | dok (x, s) = dok (x div 10, chr(x mod 10 + ord("0")) ^ s) fun fill (s, l) = if size s > l then let fun dc 0 = "" | dc l = "*" ^ dc (l-1) in dc l end else let fun dc 0 = "" | dc l = " " ^ dc (l-1) in dc (l - size s) ^ s end in if x < 0 then fill ( "-" ^ (dok (~x, "")), l) else fill (dok (x, ""), l) end Transcript: Standard ML of New Jersey, Version 0.66, 15 September 1990 val it = () : unit - emacsInit (); cd "/home/antares/pizza/users/antoy/programs/sml/random-dir/"; val it = () : unit val it = () : unit - usedbg "format.sml"; [opening /home/antares/pizza/users/antoy/programs/sml/random-dir/format.sml] [Major collection... 63% used (1343748/2106244), 1520 msec] [Increasing heap to 4104k] exception wrong_field_size val dec = fn : int * int -> string [closing /home/antares/pizza/users/antoy/programs/sml/random-dir/format.sml] val it = () : unit - run "dec(12,4)"; [opening ] :1.1-1.9 Error: operator and operand don't agree (tycon mismatch) operator domain: int ref operand: int * int in expression: dec (12,4) [closing ] - dec(12,4); val it = " 12" : string - Comments: Under epoch 3.2.4 The debugger works for a trivial factorial program. From apt@Princeton.EDU Tue Jul 2 10:28:41 1991 This is indeed a (minor) bug, which I'll handle in due course. The problem seems to be that the run function is hiding the user's (re-)definition of dec with the pervasive Integer.dec. There is a trivial work-around: call the user function something different. Status: fixed in 0.88 --------------------------------------------------------------------------- Number: 437 Title: mlyacc syntax problem Keywords: Submitter: Andrew Wright Date: 7/3/91 Version: 0.69 Problem: The source file "yacc.sml" of mlyacc from the 0.69 release does not compile under the 0.69 release because of a syntax error at line 350: EAPP(EVAR(valueStruct^"."^ if hasType (NONTERM lhs) then saySym(NONTERM lhs) else ntvoid), Fix: The "if then else" needs to be parenthesized. Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 438 Title: callcc typing unsound Keywords: Submitter: Robert Harper Date: 7/3/91 Version: 0.70 Severity: critical Problem: Recently Mark Lillibridge and I have been trying to investigate a number of questions of type soundness in the presence of polymorphism and control operators. As you may recall, I have been unable to find a cps transform that (1) is faithful to the ML operational semantics, and (2) admits a suitable typing result to guarantee soundness in Milner's sense. We discovered that the central issue is to do with the scope of type variables. This got us to thinking, and late last night Mark came up with the following example which demonstrates that ML with callcc and polymorphism is UNSOUND. Run it in SML/NJ to see what I mean. We plan to investigate the matter further, and will keep you posted. Code: fun left (x,y) = x; fun right (x,y) = y; let val later = (callcc (fn k => ( fn x => x, fn f => throw k (f, fn f => ()) ) )) in print (left(later)"hello"); right(later)(fn x => x+2) end Fix: Making the type of callcc weakly polymorphic appears to fix the problem. Status: fixed in 0.73 (by making callcc weakly polymorphic) --------------------------------------------------------------------------- Number: 439 Title: lexgen Keywords: Submitter: Julian Bradfield Date: 7/8/91 Version: 0.66 Problem: lexgen.sml distributed with NJ SML 0.66, lines 983 to 986. The variable i in the pattern clashes with i in a pattern much higher up. I *think* that all occurrences of i in these four lines should be k, say, while the i on line 987 is indeed i. (The symptom of this bug is uncaught Substring exceptions, when a state identifier gets passed as a length to accept.) Has anybody got the look-ahead facility of ML-Lex to work? Comment: Tarditi noticed that the ASU lookahead algorithm is buggy, so this feature has been removed. Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 440 Title: missing Perv.mos Keywords: Submitter: Matti Jokinen, moj@utu.fi Date: 6/15/91 Version: 0.69, 0.70, possibly others System: all Severity: major Problem: File src/runtime/Perv.mos is missing. Consequently, `makeml -pervshare' fails. Command: makeml -sun3 sunos -pervshare Transcript: makeml -sun3 sunos -pervshare ./makeml> (cd runtime; make clean) rm -f *.o lint.out prim.s linkdata allmo.s run ./makeml> rm -f mo ./makeml> ln -s ../mo.m68 mo ./makeml> (cd runtime; rm -f run allmo.o allmo.s) ./makeml> (cd runtime; make MACHINE=M68 'CFL=-n ' 'DEFS= -DBSD -Dsun3 -DSUNOS - DRUNTIME=\"runtime\"' linkdata) cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -DRUNTIME=\"runtime\" -o linkdata linkdata.c (cd runtime; grep -v mo/Math.mo Perv.mos > Tmp.mos) ---> grep: Perv.mos: No such file or directory ./makeml> runtime/linkdata [runtime/Tmp.mos] runtime/linkdata> as runtime/allmo.s -o runtime/allmo.o ./makeml> (cd runtime; make MACHINE=M68 'DEFS= -DBSD -Dsun3 -DSUNOS' CPP=/lib/ cpp 'CFL=-n ' 'AS=as') cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c run.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c run_ml.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c callgc.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c gc.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c M68.dep.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c export.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c timers.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c ml_objects.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c cfuns.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c cstruct.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c signal.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c exncode.c cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -target sun3 -c malloc.c /lib/cpp -DASM -DM68 -DBSD -Dsun3 -DSUNOS M68.prim.s > prim.s as -o prim.o prim.s cc -O -n -DM68 -DBSD -Dsun3 -DSUNOS -o run run.o run_ml.o callgc.o gc.o M68.dep. o export.o timers.o ml_objects.o cfuns.o cstruct.o signal.o exncode.o malloc.o prim.o allmo.o Undefined _datalist *** Error code 2 make: Fatal error: Command failed for target `run' Fix: Copy the missing file from distribution 0.66. Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 441 Title: parsing large positive integers Keywords: Submitter: Olaf Burkart Date: 7/16/90 Version: 0.69 System: SPARC, SunOS 4.1 Problem: I have found the following bug in sml 0.69: Can't parse large positive integers. Can't load the Edinburgh SML Library. Problem (1): 2^30 - 1 (maxint) could not be read ----------- Transcript: Standard ML of New Jersey, Version 0.69, 3 April 1991 - ~1073741824; val it = ~1073741824 : int - 1073741823; uncaught exception Overflow - Comment: [dbm] Is this the same as bug 327, which is claimed to be fixed in 0.69? Status: fixed in 0.72 --- This is related to bug 327 and 444 [lg]. --------------------------------------------------------------------------- Number: 442 Title: Runbind exception Keywords: Submitter: Olaf Burkart Date: 7/16/90 Version: 0.69 System: SPARC, SunOS 4.1 Problem: It seems to me that the Runbind error from BUG 262. is back again. I tried to load the Edinburgh SML Library, but after fixing problem (1) the sml interpreter aborts with "uncaught exception Runbind" in the structure definition: structure Int: INT = struct ... exception Overflow = Overflow and Div = Div ... end Fix: probably fixed; can't check without source (related bug 419 is fixed) Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 443 Title: equality attributes in datatype specs Keywords: Submitter: Colin Meldrum Date: 7/17/91 Version: 0.66 Problem: In New Jersey v66, the following signature does not elaborate: signature S = sig type 'a s datatype t = A of int -> int datatype v = D of w s and w = E of t end It gives the error: std_in:16.5-24.2 Error: inconsistent equality properties However, by swapping the two datdesc clauses in the final datatype spec the signature can be made to elaborate correctly: signature S = sig type 'a s datatype t = A of int -> int datatype w = E of t and v = D of w s end Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 444 Title: large constants and Overflow Keywords: This is an supplement to the bug: 327 large constants cause overflow in compilation from Apr 23. Submitter: Juergen Buntrock, TU-Berlin, jubu@cs.tu-berlin.de Date: 4/23/91 Version: 0.70 System: Sun4-60 / SunOS Release 4.1.1 Problem: The function primops in (cps/cpsopt.sml line 658) transforms integer compare operation somtimes in arithmetic operations which may raise Overflow. An example is function sizeImmed (in sparc/sparc.sml). This functions raise an Overflow for constant values bigger than (maxinit-4096) Script: Script started on Tue Jul 30 12:57:30 1991 jubu@flp 1) smln70 Standard ML of New Jersey, Version 0.70, 1 July 1991 val it = () : unit - structure TT = struct = datatype A = A | B = fun sizeImmed n = if (~4096 <= n) andalso(n < 4096) = then A else B = val sizeImmed = fn n => = (sizeImmed n) handle Overflow => ( = outputc std_out (implode[ = "sizeImmed(",makestring n, = ") overflow!\n"]); = raise Overflow ) = val x = 107374182 = val z = (sizeImmed (x * 10 + 2)) = end = ; sizeImmed(1073741822) overflow! uncaught exception Overflow Status: fixed in 0.72 This is had to do with an illegal optimization and a bug in the sparc code generator [lg]. --------------------------------------------------------------------------- Number: 445 Title: spurious error report Keywords: modules, signatures, error messages Submitter: Andrew Tolmach Date: 7/30/91 Version: 0.70 Problem: Following produces a spurious error in 0.70. Code: signature T = sig datatype debuglevel = A of instream option end Status: fixed in 0.73 --------------------------------------------------------------------------- Number: 446 Title: Compiler bug Keywords: Submitter: jont%uk.co.harlqn@uk.ac.ukc Date: 01/08/91 Version: SML of NJ version number 0.66 System: Sun 4/330 with SunOS 4.1.1 Severity: minor Problem: Compiler warns of compiler bug in compiling some incorrect code Code: (* _mirprint.sml the functor *) (* $Log$ Revision 1.1 2003/03/20 23:09:38 macqueen replaced lots of bell-labs.com links Revision 1.3 91/07/30 16:22:11 jont Printed more opcodes (branch and cgt) Revision 1.2 91/07/26 20:00:13 jont Redid some printing in light of changes in mirtypes Revision 1.1 91/07/25 15:45:09 jont Initial revision Copyright (c) 1991 Harlequin Ltd. *) require "../utils/integer"; require "../basics/identprint"; require "../lambda/pretty"; require "../lambda/lambdasub"; require "mirtypes"; require "mirprint"; functor MirPrint( structure Integer : INTEGER structure IdentPrint : IDENTPRINT structure MirTypes : MIRTYPES structure Pretty : PRETTY structure LambdaSub : LAMBDASUB sharing IdentPrint.Ident = MirTypes.Ident hsaring MirTypes.LambdaTypes = LambdaSub.LambdaTypes ) : MIRPRINT = struct structure MirTypes = MirTypes structure P = Pretty exception pretty_not_done_yet fun decode_binary MirTypes.ADD = "ADD " | decode_binary MirTypes.SUB = "SUB " | decode_binary MirTypes.MUL = "MUL " | decode_binary MirTypes.DIV = "DIV " | decode_binary MirTypes.REM = "REM " | decode_binary MirTypes.AND = "AND " | decode_binary MirTypes.OR = "OR " | decode_binary MirTypes.EOR = "EOR " | decode_binary MirTypes.SHL = "SHL " | decode_binary MirTypes.SHR = "SHR " | decode_binary MirTypes.SHRL = "SHRL " | decode_binary MirTypes.DIVL = "DIVL " | decode_binary MirTypes.REML = "REML " fun decode_unary MirTypes.CMP = "CMP " | decode_unary MirTypes.CMPL = "CMPL " | decode_unary MirTypes.MOV = "MOV " | decode_unary MirTypes.NEG = "NEG " | decode_unary MirTypes.NOT = "NOT " fun decode_store MirTypes.LDX = "LDX " | decode_store MirTypes.STX = "STX " fun decode_allocate MirTypes.ALLOC = "ALLOC " | decode_allocate MirTypes.ALLOC_REAL = "ALLOC_REAL " | decode_allocate MirTypes.ALLOC_STRING = "ALLOC_STRING " fun decode_branch MirTypes.BRA = "BRA " | decode_branch MirTypes.BEQ = "BEQ " | decode_branch MirTypes.BNE = "BNE " | decode_branch MirTypes.BHI = "BHI " | decode_branch MirTypes.BLS = "BLS " | decode_branch MirTypes.BHS = "BHS " | decode_branch MirTypes.BLO = "BLO " | decode_branch MirTypes.BGT = "BGT " | decode_branch MirTypes.BLE = "BLE " | decode_branch MirTypes.BGE = "BGE " | decode_branch MirTypes.BLT = "BLT " | decode_branch MirTypes.BVS = "BVS " | decode_branch MirTypes.BVC = "BVC " | decode_branch MirTypes.BMI = "BMI " | decode_branch MirTypes.BPL = "BPL " fun decode_adr MirTypes.LEA = "LEA " fun decode_real_gc(MirTypes.GC_REAL gc_reg) = "REG " ^ MirTypes.print_gc_register gc_reg | decode_real_gc(MirTypes.GC_SPILL i) = "SPILL " ^ Integer.makestring i fun decode_real_non_gc(MirTypes.NON_GC_REAL gc_reg) = "REG " ^ MirTypes.print_non_gc_register gc_reg | decode_real_non_gc(MirTypes.NON_GC_SPILL i) = "SPILL " ^ Integer.makestring i fun decode_reg_operand(MirTypes.GC_REG(gc_reg, real_gc_reg_opt)) = "GC(" ^ MirTypes.print_gc_register gc_reg ^ (case real_gc_reg_opt of MirTypes.ABSENT => "" | MirTypes.PRESENT real_gc => decode_real_gc real_gc) ^ ") " | decode_reg_operand(MirTypes.NON_GC_REG(non_gc_reg, real_non_gc_reg_opt)) = "NON_GC(" ^ MirTypes.print_non_gc_register non_gc_reg ^ (case real_non_gc_reg_opt of MirTypes.ABSENT => "" | MirTypes.PRESENT real_non_gc => decode_real_non_gc real_non_gc) ^ ") " fun decode_gp_op(MirTypes.GP_GC_REG(gc_reg, real_gc_reg_opt)) = "GC(" ^ MirTypes.print_gc_register gc_reg ^ (case real_gc_reg_opt of MirTypes.ABSENT => "" | MirTypes.PRESENT real_gc => decode_real_gc real_gc) ^ ") " | decode_gp_op(MirTypes.GP_NON_GC_REG(non_gc_reg, real_non_gc_reg_opt)) = "NON_GC(" ^ MirTypes.print_non_gc_register non_gc_reg ^ (case real_non_gc_reg_opt of MirTypes.ABSENT => "" | MirTypes.PRESENT real_non_gc => decode_real_non_gc real_non_gc) ^ ") " | decode_gp_op(MirTypes.GP_IMM_INT imm) = "Int(" ^ Integer.makestring imm ^ ") " | decode_gp_op(MirTypes.GP_IMM_ANY imm) = "Any(" ^ Integer.makestring imm ^ ") " fun decode_op(MirTypes.BINARY(binary_op, reg_op, gp_op1, gp_op2)) = decode_binary binary_op ^ decode_reg_operand reg_op ^ decode_gp_op gp_op1 ^ decode_gp_op gp_op2 | decode_op(MirTypes.UNARY(unary_op, reg_op, gp_op)) = decode_unary unary_op ^ decode_reg_operand reg_op ^ decode_gp_op gp_op | decode_op(MirTypes.STOREOP(store_op, reg_op1, reg_op2, gp_op)) = decode_store store_op ^ decode_reg_operand reg_op1 ^ decode_reg_operand reg_op2 ^ decode_gp_op gp_op | decode_op(MirTypes.ALLOCATE(allocate, gc_reg, imm)) = decode_allocate allocate ^ "GC(" ^ MirTypes.print_gc_register gc_reg ^ ") " ^ (case allocate of MirTypes.ALLOC_REAL => "" | _ => Integer.makestring imm) | decode_op(MirTypes.BRANCH(branch, tag)) = decode_branch branch ^ MirTypes.print_tag tag | decode_op(MirTypes.SWITCH(cgt, reg_op, tag_list)) = LambdaSub.reduce_left (fn (s, tag) => s ^ " " ^ MirTypes.print_tag tag) ("CGT " ^ decode_reg_operand reg_op, tag_list) | decode_op(MirTypes.VALUE scon) = (case scon of IdentPrint.Ident.REAL _ => "Real " | IdentPrint.Ident.STRING _ => "String " | _ => raise(LambdaSub.LambdaTypes.impossible"VALUE(int)")) ^ IdentPrint.printSCon scon | decode_op(MirTypes.ADR(adr, reg_op, tag)) = decode_adr adr ^ decode_reg_operand reg_op ^ " " ^ MirTypes.print_tag tag (* Information points *) | decode_op(MirTypes.LOC_REF tag_list) = LambdaSub.reduce_left op ^ ("Local references\n", map (fn tag => MirTypes.print_tag tag ^ " ") tag_list) | decode_op MirTypes.END = "End of code" | decode_op _ = raise(pretty_not_done_yet) (* | decode_op(MirTypes.BINARYFP of binary_fp_op * fp_register * fp_register * fp_operand | | decode_op(MirTypes.UNARYFP of unary_fp_op * fp_register * fp_operand | | decode_op(MirTypes.STACKOP of stack_op * reg_operand | | decode_op(MirTypes.STOREFPOP of store_fp_op * fp_register * reg_operand * gp_operand | | decode_op(MirTypes.CONVOP of int_to_float * fp_register * reg_operand | | decode_op(MirTypes.BRANCH_AND_LINK of branch_and_link * bl_dest | | decode_op(MirTypes.INIT of any_register | (* Register is initialised here *) | decode_op(MirTypes.USE of any_register | (* Register is used here *) | decode_op(MirTypes.ENTER of int * reg_operand | (* Entry point for procedure, with n locals and arg reg *) | decode_op(MirTypes.EXIT of reg_operand | (* Return point from procedure, result in reg *) (* Data *) *) fun decode_block(MirTypes.BLOCK(tag, op_list)) = P.blk(0, P.lst("", [P.nl], "") (P.blk(2, [P.str("Tag "), P.str(MirTypes.print_tag tag)]) :: (map (fn x => P.str(" " ^ decode_op x)) op_list))) fun print_mir_code(MirTypes.CODE block_list) = P.string_of_T(P.blk(0, P.lst("", [P.nl], "") (map decode_block block_list))) end Transcript: make "../mir/_mirprint.sml"; [opening /home/ml/jont/ml/ml_compiler/src/mir/_mirprint.sml] val it = () : unit val it = () : unit val it = () : unit val it = () : unit val it = () : unit val it = () : unit /home/ml/jont/ml/ml_compiler/src/mir/_mirprint.sml:30.3-30.9 Error: syntax error: inserting OPEN /home/ml/jont/ml/ml_compiler/src/mir/_mirprint.sml:30.3-30.54 Error: unbound structure in signature: hsaring /home/ml/jont/ml/ml_compiler/src/mir/_mirprint.sml:30.3-30.54 Error: unbound structure in signature: MirTypes.LambdaTypes Error: Compiler bug: lookPathSTRinSig.get [closing /home/ml/jont/ml/ml_compiler/src/mir/_mirprint.sml] Comments: The code is incorrect, but it shouldn't cause the compiler to claim it has a bug in itself! The cause seems somewhat related to the fact that MirTypes has no substructure LambdaTypes, simply misspelling sharing on a line which is an otherwise valid sharing constraint line does not exhibit the problem. Status: fixed in 0.73? (incomplete source, can't test) --------------------------------------------------------------------------- Number: 447 Title: identity type abbreviation Keywords: Submitter: tmb@ai.mit.edu Date: 08/02/91 Version: 0.70 System: Sun4/OS4.1.1 Severity: ? Problem: the type checker refuses to accept the following definition Code: structure S = struct type 'b data = 'b list type 'b value = 'b fun at(x:'b data):'b value = hd x end; Transcript: hack.sml:5.2-5.34 Error: expression and constraint don't agree (bound type var) expression: 'bU constraint: 'bU value in expression: Initial.hd x Comments: I'm not sure whether this is a bug, but certain types of functors seem to be difficult to express if you cannot write definitions like this. In particular, it seems like I have to write two separate functors depending on whether "'b value" is simply "'b" or whether it is some other type dependent on "'b" (e.g., "'b list"). This seems very unnatural. signature S = sig type 'a data type 'a value val at: 'b data -> 'b value end; functor F(structure X:S) = struct open X fun pair_at x = (at x,at x) end; structure A = struct type 'a data = 'a list type 'a value = 'a list val at = (fn x => x) end; structure FA = F(structure X = A); structure B = struct type 'a data = 'a list type 'a value = 'a val at = hd end; (* why can't I do this??? *) structure FB = F(structure X = B); Fix: type abbreviations must be expanded when unifying with UBOUND type variables in Unify (basics/unify.sml). The definition of equalTypes in TypesUtil must be changed in a similar manner. Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 448 Title: failure to build on MIPS 6280 Keywords: Submitter: Dave MacQueen Date: 8/10/91 Version: 0.71 System: MIPS 6280, RISCOS 4.52 Severity: critical (for 6280) Problem: failure while trying to bootstap the compiler Transcript: % makeml -mips riscos -batch -m 60000 makeml> (cd runtime; make clean) rm -f *.o lint.out prim.s linkdata allmo.s run makeml> rm -f mo makeml> ln -s ../mo.mipsb mo makeml> (cd runtime; rm -f run allmo.o allmo.s) makeml> (cd runtime; make MACHINE=MIPS 'CFL= -systype bsd43' 'LIBS=' 'DEFS= -DRISCos -DRUNTIME=\"runtime\"' linkdata) cc -O -systype bsd43 -DMIPS -DRISCos -DRUNTIME=\"runtime\" -o linkdata linkdata.c makeml> runtime/linkdata [runtime/CompMipsBig.mos] runtime/linkdata> as runtime/allmo.s -o runtime/allmo.o makeml> (cd runtime; make MACHINE=MIPS 'DEFS= -DRISCos' 'CPP=/lib/cpp -P' 'CFL= -systype bsd43' 'AS=as' 'LIBS=') cc -O -systype bsd43 -DMIPS -DRISCos -c run.c cc -O -systype bsd43 -DMIPS -DRISCos -c run_ml.c cc -O -systype bsd43 -DMIPS -DRISCos -c callgc.c cc -O -systype bsd43 -DMIPS -DRISCos -c gc.c uopt: Warning: gc: this procedure not optimized because it exceeds size threshold; to optimize this procedure, use -Olimit option with value >= 553. cc -O -systype bsd43 -DMIPS -DRISCos -c MIPS.dep.c cc -O -systype bsd43 -DMIPS -DRISCos -c export.c cc -O -systype bsd43 -DMIPS -DRISCos -c timers.c cc -O -systype bsd43 -DMIPS -DRISCos -c ml_objects.c cc -O -systype bsd43 -DMIPS -DRISCos -c cfuns.c cc -O -systype bsd43 -DMIPS -DRISCos -c cstruct.c cc -O -systype bsd43 -DMIPS -DRISCos -c signal.c cc -O -systype bsd43 -DMIPS -DRISCos -c exncode.c cc -O -systype bsd43 -DMIPS -DRISCos -c malloc.c cc -O -systype bsd43 -DMIPS -DRISCos -c mp.c cc -O -systype bsd43 -DMIPS -DRISCos -c sync.c /lib/cpp -P -DASM -DMIPS -DRISCos MIPS.prim.s > prim.s as -o prim.o prim.s as0: Warning: prim.s, line 281: missing .end preceding this .ent: set_request .ent set_request as0: Warning: prim.s, line 281: .ent/.end block never defined the procedure name as0: Warning: prim.s, line 407: missing .end preceding this .ent: go .ent go cc -O -systype bsd43 -DMIPS -DRISCos -o run run.o run_ml.o callgc.o gc.o MIPS.dep.o export.o timers.o ml_objects.o cfuns.o cstruct.o signal.o exncode.o malloc.o mp.o sync.o prim.o allmo.o makeml> runtime/run -m 60000 -r 5 -h 2048 CompMipsBig [Increasing heap to 2048k] [Loading mo/CoreFunc.mo] [Executing mo/CoreFunc.mo] [Loading mo/Math.mo] [Executing mo/Math.mo] [Loading mo/Initial.mo] [Executing mo/Initial.mo] Uncaught exception CFunNotFound with "argv" 9.2u 7.8s 1:22 20% 182+737k 1269+1532io 2586pf+0w Comments: The as0 warnings should be eliminated, and the -Olimit flag added or changed so that the gc code can be optimized. Status: fixed in 0.78 --------------------------------------------------------------------------- Number: 449 Title: poor error message for mismatching datatype spec Keywords: Submitter: John Reppy (jhr@cs.cornell.edu) Date: 3/5/91 Version: 0.66-0.69 Severity: minor Problem: Here is another example of an error message that doesn't give enough info: user/drawing.sml:9.3-12.5 Error: mismatching datatype spec: pen_val_t In this case, pen_val_t has ~30 variants; figuring out the mismatch is a pain. This is like the problem with large labeled records. - John Status: fixed in 0.91 (dbm) --------------------------------------------------------------------------- Number: 450 Title: Compiler bug: tycPath Keywords: Submitter: Andy Koenig (dopey!ark) Date: 10/16/91 Version: 0.66 Severity: minor Problem: After an unmatched type spec there is a Compiler bug message. Transcript: - signature I = sig type T end; signature I = sig type T end - abstraction J : I = struct type u = int end; std_in:1.21-1.43 Error: unmatched type spec: T Error: Compiler bug: tycPath Status: fixed in 0.74 --------------------------------------------------------------------------- Number: 451 Title: sharing constraints Keywords: Submitter: Mike Crawley Date: 10/29/91 Version: 0.73 Severity: serious Problem: SML/NJ 0.73 gets the sharing constraints wrong in the following ML. Code: signature A = sig structure Base:sig end end; signature P = sig end; functor A (structure P:P) : A = struct structure Base = P; end; signature B = sig structure Base:sig end end; functor B (structure P:P structure A:A sharing P = A.Base ) : B = struct structure Base = P; end; functor Q(structure P : P structure A : A structure B : B sharing P = A.Base = B.Base) = struct end ; structure P = struct end ; structure A = A(structure P = P); structure B = B(structure P = P structure A = A); structure Q = Q(structure P = P structure A = A structure B = B); Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 452 Title: finding out what is in a structure Keywords: Submitter: Tim Freeman, tsf@cs.cmu.edu Date: 10/30/91 Version: 0.74 System: Sun 4 Severity: minor but chronic Problem: I used to be able to find out what was in a structure by opening it up. Now there is apparently no way to remind myself of what is in a structure other than by reading the source. Transcript: - structure x = SourceGroup; structure x : SOURCEGROUP (* This used to tell me all of the things in the SourceGroup structure. *) - open x; open x (* I would be just as happy if this printed out the information I want too. *) Comments: Maybe this feature should have its own name, instead of hanging off of top level structure declarations. Status: not a bug --------------------------------------------------------------------------- Number: 453 Title: unhandled exception crashes sml Keywords: Submitter: Tim Freeman Date: 10/31/91 Version: 0.74 System: Sun 4 running some version of Mach Severity: minor Problem: With some manipulations of structures, raising unhandled exceptions causes SML to bomb. Code: bug3.sml contains: structure Util = struct exception Bug of string end structure InstProto = struct structure U = Util structure S = struct end end open InstProto ; raise U.Bug "hi" Transcript: % sml Standard ML of New Jersey, Version 0.74, 10 October, 1991 Prerelease version. Arrays have changed; see doc/NEWS val it = () : unit - use "bug3.sml"; [opening bug3.sml] structure Util : sig exception Bug of string end structure InstProto : sig structure S : ... structure U : ... end open InstProto SIGILL code 0x7 % Comments: Earlier during the process of narrowing down this bug, it was saying uncaught exception random binary garbage (except you have to imagine the string "random binary garbage" replaced by random binary garbage) instead of getting the SIGILL trap. Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 454 Title: running out of memory Keywords: Submitter: Andy Koenig Date: 11/7/91 Version: 0.74 System: SPARCstation, 64MB Severity: minor Problem: SML-NJ is not very nice about handling memory exhaustion. Transcript: [boojum] sml Standard ML of New Jersey, Version 0.74, 10 October, 1991 Prerelease version. Arrays have changed; see doc/NEWS val it = () : unit - fun f x = f(0::x); val f = fn : int list -> 'a - f nil; [Increasing heap to 3164k] [Increasing heap to 4452k] [Increasing heap to 5456k] [Major collection... [Increasing heap to 8192k] 76% used (3427160/4508104), 2610 msec] [Increasing heap to 13192k] [Major collection... 49% used (4497848/8999168), 4600 msec] [Increasing heap to 26380k] [Major collection... 49% used (8999168/18002072), 9250 msec] [Increasing heap to 27204k] [Major collection... [Increasing heap to 27620k] [Increasing heap to 27776k] [Increasing heap to 27860k] [Increasing heap to 27880k] Warning: can't increase heap Ran out of memory[boojum] Comments: While I do ultimately expect some kind of drastic termination, I do **NOT** expect to be unceremoniously dumped out of ML back into the Shell. A more reasonable strategy might be to preallocate a chunk of memory to be used as secondary storage while recovering from exhaustion of primary storage. That, at least, would allow for a return to top level and associated garbage collection, which, in many cases, would allow interactive execution to resume. Incidentally, this example was run on a Sparcstation with 64 megabytes of physical memory and no limit on process size that I know of. I don't know why it gave up the ghost at 28 megabytes -- do you? Owner: Status: open --------------------------------------------------------------------------- Number: 455 Title: handling Real.Div Keywords: Submitter: olender@cs.colostate.edu Date: 11/11/91 Version: 0.75 System: Sparcstation-2/SunOS 4.1.1 Severity: minor Problem: cannot handle Real.Div exception Code: 1.0/0.0 handle Real.Div => 10.0; Transcript: (* At top level *) (* Integer works *) - 1 div 0 handle Integer.Div => 10; val it = 10 : int (* Real doesn't *) - 1.0/0.0 handle Real.Div => 10.0; uncaught exception Div (* Even when I don't specify the name *) - 1.0/0.0 handle _ => 10.0; uncaught exception Div Fix: This was a bug in the scheduler dependencies for the SPARC. Status: fixed in 0.76 --------------------------------------------------------------------------- Number: 456 Title: signals on SPARC cause heap corruption Keywords: Submitter: tyan@cs.cornell.edu & Greg_Morrisett@CS.CMU.EDU Date: 11/20/91 Version: 0.75 (and earlier) System: Sparc Severity: minor Problem: programs using signals to do pre-emption get corrupted heaps. Code: (* A simple preemptive thread structure *) structure T = struct (* Queues *) type '1a queue = ('1a list ref * '1a list ref) fun create () = (ref [], ref []) fun enq ((f,r), x) = r := x :: (!r) fun deq (f,r) = (case (!f) of (hd::tl) => (f := tl; SOME hd) | [] => (case (rev (!r)) of (hd::tl) => (f := tl; r := []; SOME hd) | [] => NONE)) (* Flag for atomicity *) val atomic = ref false (* Ready queue *) val ready : unit cont queue = create () exception Deadlock fun enterAtomic () = atomic := true fun leaveAtomic () = atomic := false fun reschedule k = enq (ready, k) fun get_next () = case (deq ready) of NONE => raise Deadlock | SOME k => k (* fork a thread *) fun fork f = (enterAtomic (); callcc (fn c => (reschedule c; leaveAtomic (); f (); enterAtomic (); throw (get_next ()) ())); leaveAtomic ()) fun prepend f kont = (callcc (fn c => (callcc (fn k => (throw c k)); f (); throw kont ()))) (* context switch signal handler *) fun handler (n,kont) = if (!atomic) then (kont) else (enterAtomic (); reschedule (prepend leaveAtomic kont); get_next ()) local open System.Signals System.Timer System.Unsafe.CInterface val t0 = TIME {sec=0,usec=0} in val _ = setHandler (SIGALRM, SOME handler) fun setPreempt NONE = setitimer(0,t0,t0) | setPreempt (SOME t) = let val t = TIME {sec=0,usec=1000*t} in setitimer(0,t,t) end end end fun spin_alloc l = spin_alloc (rev l); (* make sure we fool compiler *) fun spin () = spin_alloc [1,2]; fun bug () = (T.setPreempt (SOME 50); T.fork spin; T.fork spin; T.fork spin) Fix: The problem was that the SPARC has no callee saved FP registers, so the resumption continuation was pointing to its own descriptor. Status: fixed in 0.76 --------------------------------------------------------------------------- Number: 457 Title: Real.ceiling has wrong type Keywords: Submitter: Lal George Date: 11/22/91 Version: 0.75 (and earlier) System: all Severity: minor Problem: Real.ceiling has wrong type Code: - ceiling; val it = fn : real -> 'a Remark: yet another example of the brain damage in perv.sml Status: fixed in 0.76 --------------------------------------------------------------------------- Number: 458 Title: incorrect 'Warning: binding not exhaustive' message Keywords: Submitter: Lal George Date: 11/27/91 Version: 0.75 (and earlier) System: all Severity: minor Code: datatype register = Reg of int | Freg of int datatype ea = Direct of register | Immed of int val dataptr as Direct dataptr' = Direct(Reg 23) Transcript: - val dataptr as Direct dataptr' = Direct(Reg 23); std_in:4.1-4.47 Warning: binding not exhaustive dataptr as Direct dataptr' = ... val dataptr = Direct (Reg 23) : ea val dataptr' = Reg 23 : register Comment: [dbm] Further static analysis could verify that this pattern would be matched, but this analysis is not done. Status: not a bug --------------------------------------------------------------------------- Number: 459 Title: signature matching Keywords: Submitter: Robert Thau, rst@ai.mit.edu Date: 12/10/91 Version: 75 System: Sparcstation 1 / SunOS 4.1.1 Severity: Problem: The following two lines of admittedly questionable code seem to throw the SML/NJ compiler into a loop, madly consing with no apparent end in sight. Code: signature foosig = sig val foo: 'a -> int end; structure foostruct:foosig = struct fun foo x = x end; Status: fixed in 0.80 (or earlier) --------------------------------------------------------------------------- Number: 460 Title: signature matching Keywords: Submitter: Tsung-Min Kuo (email : kuo@ecrc.de) Date: 12/12/91 Version: Version 0.75, November 11, 1991 System: SPARCstation 1, SUNOS 4.1 Severity: VERY severe Problem: Compiler blowup --- use up 24M heap Code: signature A = sig val s : (unit -> 'a) -> unit end structure A : A = struct fun s f = f() end Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - signature A = sig val s : (unit -> 'a) -> unit end; signature A = sig val s : (unit -> 'a) -> unit end - structure A : A = struct fun s f = f() end; [Increasing heap to 10003k] [Major collection... 69% used (3607244/5171504), 6790 msec] [Increasing heap to 15147k] [Major collection... [Increasing heap to 23187k] 80% used (7597900/9458020), 12920 msec] [Increasing heap to 23467k] [Major collection... 73% used (9457996/12885048), 17240 msec] [Increasing heap to 23575k] 2[Major collection... [Increasing heap to 23647k] Warning: can't increase heap Ran out of memory Comments: The signature was wrong. But, instead of reporting spec mismatch, it keeps on doing heap allocation until runs out of memory. By fixing the signature, or by avoiding signature constraint on the structure definition, we can get around the bug. The old version (0.66) seems working correctly on this example. Submitter: Francois Bourdoncle >Date: 3/13/92 Version: 0.75 System: Ultrix 4.2 on a DECstation 5200 (but also VAX 8600) Problem: compiler loops on erroneous signature matching Code: signature SIG = sig val F : 'a -> unit end structure S : SIG = struct fun F x = x end; Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "bug.sml"; [opening bug.sml] [Increasing heap to 4058k] [Increasing heap to 7678k] [Increasing heap to 14398k] [Increasing heap to 16386k] [Major collection... 69% used (5815684/8396812), 7367 msec] [Increasing heap to 24602k] ^C[closing bug.sml] Interrupt - ^C Status: fixed in 0.80 (or earlier) --------------------------------------------------------------------------- Number: 461 Title: overloading and weak polymorphism Keywords: Submitter: jont@uk.co.harlqn Date: 12/1/91 Version: SML of NJ version number, 0.75 System: Sun 4/330 with SunOS 4.1.1 Severity: minor Problem: Problem with weak type variables Code: local val x = ref nil in fun define(y: string list) = x := y end; Transcript: - use "bug461.sml"; bug461.sml:5.3-5.17 Error: nongeneric weak type variable x : '0Z list ref [closing bug461.sml] Comments: 0.66 accepted this quite happily. As far as I can see, there is no problem deducing the type of overloads Status: fixed in 0.89 --------------------------------------------------------------------------- Number: 462 Title: location info in inexhaustive pattern warnings Keywords: Submitter: Bob Harper (Robert_Harper@cs.cmu.edu) Date: 12/4/91 Version: 0.75 Problem: My inexhaustive pattern warnings come out thus these days: .../src/type-check.sml:0.0-0.0 Warning: match not exhaustive The line and column number are not 0! The messages always have 0 for both. Comment: Is marking turned off? Status: fixed in 0.89 --------------------------------------------------------------------------- Number: 463 Title: unmatched datatype in signature matching Keywords: Submitter : Sylvie Thiebaux sylvie@gmd.de Date: 07/10/91 Version SML 0.66 Severity major (critical ?) Problem : unmatched datatype Code : I cannot narrow down the cause of the problem more than I have already done. I have got several files in which I let only the necessary things. All the files excpeted the main file can be compliled. When I compile the main file I get the error ``unmatched datatype literal'' at the point indicated in the program. It is maybe a problem of a sharing constraint on this type that I have given in the file LOGIC.sml. But I have already used the LOGIC signature in a larger programm and this sharing constraint seemed to cause no problem. Here are all the modules involved in the error message. Please do not be surprised about what each module contains. I need each of them but I wanted to let in each of them only the minimal necessary code in order to make your task easier. (*file ELEMENT.sml*) signature ELEMENT = sig type element val put : outstream -> element -> unit end (************************************************************) (*file EQ.sml*) import "ELEMENT"; signature EQ = sig include ELEMENT val eq : element -> element -> bool end (**********************************************************) (*file SET.sml*) import "EQ"; signature SET = sig structure Eq : EQ type element sharing type element = Eq.element type set; val empty_set : set (* unrelated to the error *) end (**********************************************************) (*file ListSet.sml*) import "EQ"; import "SET"; functor ListSet (Eq' :EQ) : SET = struct structure Eq = Eq' type element = Eq.element type set = element list val empty_set :set = [] end (********************************************************) (* file ATOMS.sml *) signature ATOMS = sig type term type atom val eq_at : atom -> atom -> bool val put_at : outstream -> atom -> unit end (******************************************************) (*file LOGIC.sml*) import "SET"; import "ATOMS"; signature LOGIC = sig structure At : ATOMS datatype literal = False | True | neg of At.atom | pos of At.atom type conj_set structure CS : SET sharing type literal = CS.element (* if you remove this sharing constraint, the error does not exist any more. But I need this constraint and anyway, it caused no problem whith other big programms including this signature *) and type conj_set = CS.set end (************************************************************************) (*file Logic.sml*) import "ListSet"; import "ATOMS"; import "LOGIC"; functor Logic ( atoms : ATOMS ) : LOGIC = struct structure At = atoms datatype literal = pos of At.atom | neg of At.atom | True | False fun put_lit os (pos at) = At.put_at os at | put_lit os (neg at) = ((output (os,"-")); (At.put_at os at)) | put_lit os (True) = output(os,"true") | put_lit os (False) = output(os,"false") fun eq_lit (pos at1 :literal) (pos at2 :literal) = At.eq_at at1 at2 | eq_lit (neg at1 :literal) (neg at2 :literal) = At.eq_at at1 at2 | eq_lit True True = true | eq_lit False False = true | eq_lit _ _ = false structure CS = ListSet (struct type element = literal val eq = eq_lit val put = put_lit end) type conj_set = CS.set end (*****************************************************************) (*file LOGIC_JUSTIF.sml*) import "LOGIC"; signature LOGIC_JUSTIF = sig structure L : LOGIC datatype rule = implication of L.literal list * L.literal | inconsistency of L.literal list end (***************************************************************) (* file Logic_justif.sml*) import "ATOMS"; import "Logic"; import "LOGIC_JUSTIF"; functor Logic_justif (atoms: ATOMS) : LOGIC_JUSTIF = struct structure L : LOGIC = Logic(atoms) datatype rule = implication of L.literal list * L.literal | inconsistency of L.literal list end (****************************************************************) (*file LOGIC_JUSTIF_AND_INIT.sml *) import "LOGIC_JUSTIF"; signature LOGIC_JUSTIF_AND_INIT = sig structure LJ : LOGIC_JUSTIF val background_knowledge : LJ.rule list end (****************************************************************) (* file POSS.sml *) import "LOGIC"; signature POSS = sig structure L : LOGIC end (***************************************************) (*file Poss.sml *) import "LOGIC_JUSTIF_AND_INIT"; import "POSS"; functor Poss (lji : LOGIC_JUSTIF_AND_INIT) : POSS = struct structure L = lji.LJ.L end (***************************************************) (*file NOTHING.sml*) import "POSS"; signature NOTHING = sig structure P : POSS end (***********************************) (* file Nothing.sml*) import "POSS"; import "NOTHING"; functor Nothing (PW:POSS) : NOTHING = struct structure P = PW end (***********************************) (* main programm : Block.sml*) import "Logic_justif"; import "Poss"; import "NOTHING"; (* curiously, if you remove this last import, the error message does not appear *) structure atoms = struct datatype term = a | b | c datatype atom = on of term * term | ontable of term | holding of term | clear of term | handempty fun t2s a = "a" | t2s b = "b" | t2s c = "c" fun a2s (on(X,Y)) = "on("^(t2s X)^", "^(t2s Y)^")" | a2s (ontable X) = "ontable("^(t2s X)^")" | a2s (holding X) = "holding("^(t2s X)^")" | a2s (clear X) = "clear("^(t2s X)^")" | a2s handempty = "handempty" fun put_at os (at:atom) = output(os, a2s(at)) fun eq_at (at1:atom) (at2:atom) = at1=at2 end structure logic_justif : LOGIC_JUSTIF = Logic_justif(atoms) open logic_justif open L open atoms val back_klg = nil structure logic_justif_and_init : LOGIC_JUSTIF_AND_INIT = struct structure LJ = logic_justif val background_knowledge = back_klg end (******************************************) structure poss : POSS = Poss(logic_justif_and_init) (* this is the line where the error message appears *) Comment: may be fixed in 0.75 -- check. Status: fixed in 0.88 --------------------------------------------------------------------------- Number: 464 Title: defining exception as data constructor Keywords: Submitter: David Tarditi Date: 7/19/91 Version: 0.70 Severity: minor Problem: The following results in a compiler bug message in version 0.70: datatype d = D; exception e = D; The error message is: Error: Compiler bug: in makedec EXCEPTIONdec Comment: This is probably due to the fact that exceptions and constructors share the same name space. A check that the binding for the rhs of "exception e = ..." is an exception is probably missing. Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 465 Title: opening unbound structure id in signature Keywords: Submitter: David Tarditi Date: 7/19/91 Version: 0.70 Severity: minor Problem: The compiler falls over with the exception UnboundTable if you try to open an undefined structure in a signature. Code: signature S = sig open T (* T is undefined *) end Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 466 Title: looping error message Keywords: Submitter: Matti Jokinen, moj@utu.fi Date: 6/22/91 Version: 0.69, 0.70, possibly others System: probably all Severity: minor for an experienced user, but confusing to novices Problem: unterminating error message Code: fun f (p,q) = let fun g (p,q) = #1 q orelse f (p,q) in g (p, #2 q) end; Transcript: - fun f (p,q) = = let fun g (p,q) = #1 q orelse f (p,q) = in g (p, #2 q) = end; std_in:2.9-2.41 Error: unresolved flex record in let pattern type: {1:bool,...} std_in:1.1-4.3 Error: unresolved flex record in let pattern type: {1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1 :bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1 :bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1 :bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1:bool,2:{1 - - - Comments: Can be interrupted with ^c. Status: fixed in 0.80 --------------------------------------------------------------------------- Number: 467 Title: missing newline in declaration echo Keywords: Submitter: Matti Jokinen (moj@utu.fi) Date: 7/23/91 Version: 0.69, 0.70, possibly others System: all Severity: minor Problem: Fixity declarations are echoed without newlines. Code: infix L; infixr R; nonfix N; Transcript: - infix L; infixr R; nonfix N; infix Linfixr Rnonfix N- ^ This is the next prompt. Fix: Add `newline()' at the end of the printFixity function defined in src/print/printdec.sml: *** printdec.sml.orig Thu Mar 14 17:50:22 1991 --- printdec.sml Mon Jul 22 04:11:27 1991 *************** *** 215,227 **** and printFixity{fixity,ops} = (case fixity of NONfix => print "nonfix " | INfix (i,_) => (if i mod 2 = 0 then print "infix " else print "infixr "; if i div 2 > 0 then (print (i div 2); print " ") else ()); ! printSequence " " printSym ops) --- 215,228 ---- and printFixity{fixity,ops} = (case fixity of NONfix => print "nonfix " | INfix (i,_) => (if i mod 2 = 0 then print "infix " else print "infixr "; if i div 2 > 0 then (print (i div 2); print " ") else ()); ! printSequence " " printSym ops; ! newline()) Status: fixed in 0.75 --------------------------------------------------------------------------- Number: 468 Title: extra comma in printing unit record Keywords: Submitter: Thomas Yan (Cornell) Date: 11/18/91 Version: 0.75 Severity: minor Problem: Extra comma in printing unit record: Transcript: - val {...} = (); std_in:2.1-2.14 Warning: binding contains no variables {,...} = ... Status: fixed in 0.85 --------------------------------------------------------------------------- Number: 469 Title: infix precedence bound Keywords: Submitter: Thomas Yan (Cornell) Date: 11/18/91 Version: 0.75 Severity: minor Problem: Infix declaration allows values greater than 9: Transcript: - infix 10 +; infix 10 + Status: fixed in 0.90 --------------------------------------------------------------------------- Number: 470 Title: top-level continuations Keywords: Submitter: Francis.Dupont@inria.fr Date: 11/23/91 Version: 0.75 System: all systems (tested on Sun4/75 running SunOS4.1.1) Severity: major Problem: the typing of toplevel continuation is incorrect Code: see later Transcript: see later Comments: this bug cannot be corrected because toplevel continuations (implied by call/cc) are not compatible with SML type system (see all the literature on this topics, for intance my PhD thesis if you can read French...) Fix: Easy : drop call/cc (use limited static continuations) The code and the bug : % sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - datatype foo = None | Kont of int cont; datatype foo con Kont : int cont -> foo con None : foo - val x = ref None; val x = ref None : foo ref - callcc (fn k => (x := Kont k; 1)); val it = 1 : int - val y = (fn (Kont k) => k) (!x); std_in:5.10-5.25 Warning: match not exhaustive Kont k => ... val y = cont : int cont - val f = (throw y : int -> bool); val f = fn : int -> bool - f 1; val it = 1 : int Francis.Dupont@inria.fr PS : a variant of this bug is described in report 145 "stale top-level continuations cause type bugs" (cf doc/bugs/masterbugs) and its status is "fixed in 0.49" (sorry, it cannot be fixed) ! Status: fixed in 0.82 (but further investigation is warranted) --------------------------------------------------------------------------- Number: 471 Title: allocating large arrays Keywords: Submitter: Mike Crawley Date: 11/26/91 Version: 0.75 Severity: serious Problem: Sometimes it will crash when allocating very large arrays. Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - open Array; open Array - infix 7 sub; infix 7 sub - fun Sieve n = let val A = array (n,false) ; fun set i di = if i < n then (update (A,i,true) ; set (i+di) di ) else () ; fun get 1 acc = acc | get i acc = get (i-1) (if A sub i then acc else i :: acc) ; fun siv i = if i >= n then [] else if (A sub i) = false then (set (i+i) i ; siv (i+1)) else siv (i+1) ; in siv 2 ; get (n-1) [] end ; val Sieve = fn : int -> int list - Sieve 3628800; Segmentation fault (core dumped) But it works if I do it more gently. Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - open Array; open Array - infix 7 sub; infix 7 sub - fun Sieve n = let val A = array (n,false) ; fun set i di = if i < n then (update (A,i,true) ; set (i+di) di ) else () ; fun get 1 acc = acc | get i acc = get (i-1) (if A sub i then acc else i :: acc) ; fun siv i = if i >= n then [] else if (A sub i) = false then (set (i+i) i ; siv (i+1)) else siv (i+1) ; in siv 2 ; get (n-1) [] end ; val Sieve = fn : int -> int list - Sieve 1000000; [Increasing heap to 2952k] [Increasing heap to 5792k] [Increasing heap to 8192k] [Major collection... 63% used (412372/652688), 250 msec] [Increasing heap to 12544k] val it = [2,3,5,7,11,13,17,19,23,29,31,37,...] : int list - Sieve 3628800; [Major collection... 25% used (1354396/5356616), 880 msec] [Increasing heap to 14944k] [Major collection... 99% used (1354396/1354396), 870 msec] [Increasing heap to 24408k] [Major collection... 99% used (1354396/1354396), 860 msec] [Increasing heap to 38600k] [Increasing heap to 42544k] val it = [2,3,5,7,11,13,17,19,23,29,31,37,...] : int list - Comments: This occurs in Standard ML of New Jersey, Version 75, November 11, 1991 Standard ML of New Jersey, Version 0.73, 10 September 1991 Standard ML of New Jersey, Version 0.66, 15 September 1990 so I think it is the memory allocation rather than the new Array structure. Status: fixed in 0.84 --------------------------------------------------------------------------- Number: 472 Title: growing heap Keywords: Submitter: Simon Finn Date: 11/26/91 Version: 0.75 System: ? Severity: serious Problem: SML/NJ version 0.75 seems to have a problem when asked to grow the heap by a large factor. Transcript: this works: Perky% /ml/njml/mlsave.75/src/sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - val y = Array.array (1000000,true); [Increasing heap to 4020k] [Increasing heap to 8192k] [Major collection... 98% used (409232/414048), 260 msec] [Increasing heap to 12884k] val y = prim? : bool array - val x = Array.array (2000000,true); [Increasing heap to 16636k] [Major collection... 99% used (4409484/4411876), 1770 msec] [Increasing heap to 31412k] val x = prim? : bool array but this doesn't: - Perky% !! /ml/njml/mlsave.75/src/sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - val x = Array.array (2000000,true); Segmentation fault (core dumped) Perky% Status: fixed in 0.84 --------------------------------------------------------------------------- Number: 473 Title: inadequate error message Keywords: Submitter: George Otto (ptah!otto) Date: 11/27/91 Version: 0.75? Severity: minor Problem: I put some ML datatype definitions into a file and then brought them into ML using the command use "file"; I got back the error message "duplicate constructor" with no other information. Couldn't this be more helpful and mention the name of the constructor it is reporting about? Status: fixed in 0.91 (dbm) --------------------------------------------------------------------------- Number: 474 Title: compiler bug: patType -- unexpected pattern Keywords: Submitter: John Reppy Date: 12/6/91 Version: 0.75 Severity: minor Problem: Compiler bug: patType -- unexpected pattern Code: (* extract the draw_cmd, id and depth of a drawable *) fun infoOfDrawable (DRAWABLE{draw_cmd, DWIN w}) = let val WIN{id, scr_depth=SCRDEPTH{depth, ...}, ...} = w in {draw_cmd=draw_cmd, id=id, depth=depth} end | infoOfDrawable (DRAWABLE{draw_cmd, DPM pm}) = let val PM{id, scr_depth=SCRDEPTH{depth, ...}, ...} = pm in {draw_cmd=draw_cmd, id=id, depth=depth} end Transcript: window/draw.sml:16.51 Error: syntax error: inserting AS window/draw.sml:21.43-21.44 Error: syntax error: inserting AS Error: Compiler bug: patType -- unexpected pattern Comments: couldn't isolate small example (same as #515) Status: fixed in 0.83 --------------------------------------------------------------------------- Number: 475 Title: LOOKUP exception from mllex (see also 510, 516) Keywords: Submitter: Markus Freericks, mfx@cs.tu-berlin.de Date: 12/12/91 Version: Standard ML of New Jersey, Version 75, November 11, 1991 System: Sparc Severity: quite minor Problem: When I use a regular expression that isn't defined, I get an unhelpful exception LOOKUP. This exception is not mentioned in lexgen.doc, and there is no indication as to where the problem occurs in the input file. Code: (* bug *) %% %% {xxx} => {()}; Transcript: mfx@marx [77]% sml-lex bug ? sml-lex: uncaught exception LOOKUP or - use "lexgen.sml"; [opening lexgen.sml] lexgen.sml:1127.5-1131.57 Warning: match not exhaustive (true,129) => ... (true,256) => ... (false,129) => ... (false,256) => ... lexgen.sml:876.2-895.10 Warning: match not exhaustive (nil,nil) => ... (a :: a',b :: b') => ... lexgen.sml:854.19-855.48 Warning: match not exhaustive 1 => ... 2 => ... 3 => ... lexgen.sml:813.9-813.55 Warning: match not exhaustive (tl,el) :: r => ... functor RedBlack : signature LEXGEN = sig val lexGen : string -> unit end structure LexGen : LEXGEN [closing lexgen.sml] val it = () : unit - LexGen.lexGen "bug"; uncaught exception LOOKUP Comments: Being what could be called a 'naive user', I first thought my installation of SML and/or lexgen.sml to be in error. The warnings encountered when loading lexgen.sml added to this impression. Fix: A change to the doc should be enough; the error in the input file is easy enough to find when one knows what to search for. Status: fixed in 0.91 (Tarditi) --------------------------------------------------------------------------- Number: 476 Title: sml-lex Keywords: Submitter: Denys Duchier Date: 12/11/91 Version: 0.75 Severity: minor Problem: sml-lex (with SML V75) produces a lexer that contains D and T states when I use the special character $. Here is the source: Code: datatype lexresult = EOF; fun eof () = EOF; %% %% ";".*$ => (lex()); Comments: the rule is meant to parse a lisp-style comment. Andrew sez: I'm not sure that this is really a bug. Perhaps the documentation needs to be changed? Status: fixed in 0.91 (Tarditi) --------------------------------------------------------------------------- Number: 477 Title: duplicate specifications through include Keywords: Submitter: Nick Rothwell Date: 10/21/91 Version: 0.73 Severity: minor Problem: I enclose a short-ish (40 line) program. It compiles under poplog and one version of poly. It fails under another version of poly and with different errors under two versions of SML/NJ. By my reckoning, the program is legal SML. Code: signature MONO_SET = sig type Element type Set type T sharing type T = Set end; functor MonoSet(type T): MONO_SET = struct abstype Set = Set of T list with type Element = T type T = Set end end; signature INPUT_VAR = sig type InputVar type InputVarSet include MONO_SET sharing type Element = InputVar and type Set = InputVarSet type T sharing type T = InputVar end; functor InputVar(): INPUT_VAR = struct datatype InputVar = INPUT_VAR of string local structure S = MonoSet(type T = InputVar) in open S type InputVarSet = Set end type T = InputVar end; Transcript: X.sml:25.10 Error: duplicate specifications for type constructor T in signature Comments: a deliberate divergence from the Definition. Status: not a bug ---------------------------------------------------------------------- Number: 478 Title: order of type definitions in withtype clause Keywords: Submitter: Andrew Appel Date: 10/11/91 Version: 0.73 Severity: minor Problem: Type definitions in withtype clause have to be ordered properly. Code: datatype foo = T withtype a = b and b = foo Comments: I think this is correct. Have to check Definition. Status: not a bug ---------------------------------------------------------------------- Number: 479 Title: Boxity exception in vector_n Keywords: Submitter: Andrew Koenig Date: 10/22/91 Version: ? Severity: major Problem: Applying vector_n with index out of bounds yields Boxity exception. Transcript: - open Vector; open Vector - infix 9 sub; infix 9 sub - val x = vector_n(10,[1,2,3]); val x = - : int vector - length(x); val it = 10 : int - x sub 0; val it = 1 : int - x sub 1; val it = 2 : int - x sub 2; val it = 3 : int - x sub 3; val it = 8 : int - x sub 4; val it = uncaught exception Boxity Comments: vector_n was not supposed to be exported. Status: fixed in 0.75 ---------------------------------------------------------------------- Number: 480 Title: Exit status of makeml is 1. Keywords: Submitter: David Tarditi Date: 10/23/91 Version: 0.75? Severity: minor Problem: makeml almost always returns an exit status of 1, which indicates failure. This is because as a shell program it returns the value of its last command, which is an if-statement that almost always "fails" (the value of the if-statement is the last simple command that it executes, which is a test that fails; there is no "else" clause to execute). This creates problems for me when I use a makefile that invokes makeml to build sml images. Could you make the last statement in makeml "exit 0" ? Comments: Status: fixed in 0.89 ---------------------------------------------------------------------- Number: 481 Title: redeclared constructors Keywords: signatures, multiple specifications Submitter: Mike Crawley Date: 10/28/91 Version: 0.73 Severity: minor Problem: SML/NJ 0.73 does not accept the following valid ML program Code: signature S = sig datatype a = A | B of string ; datatype b = B | C ; end ; functor F(S:S) = struct open S ; fun matchA A = true | matchA _ = false ; fun matchB B = true | matchB _ = false ; fun matchC C = true | matchC _ = false ; end ; structure S = F ( datatype a = A | B of string ; datatype b = B | C ) ; Owner: dbm Status: not a bug (not allowed in SML 96) ---------------------------------------------------------------------- Number: 482 Title: "constant" unary type abbreviations in signature matching Keywords: Submitter: Mike Crawley Date: 10/28/91 Version: 0.73 Severity: significant Problem: Poly/ML allows this; SML/NJ 0.73 doesn't It all depends whether or not you expand the type-abbreviation t when you match the datatype d. Code: signature A = sig eqtype 'a t datatype d = C | D of int t end; structure Z = struct type 'a t = bool datatype d = C | D of bool t end; structure X : A = Z; Status: fixed in 0.80 ---------------------------------------------------------------------- Number: 483 Title: lexgen compilation blowup Keywords: Submitter: Lie Ma, ma@cs.pdx.edu Date: 10/29/91 Version: SML Ver.0.66 System: Sun Sparc Code: lexgen.sml Ver. 1.3, Dec'89 Encl: typescript Problem: I'm using lexgen to write a lexer for a formal specification language. According to the manual, I should use lexgen.sml in the following way: quote: Running ML-Lex Use "lexgen.sml"; this will create a structre LexGen. The function LexGen.lexGen creates a program for a lexer from an input specification. It takes a string argument -- the name of the file containing the input spacification. The output file name is determined by appending ".sml" to the input file name. end{quote} I got the extremly poor performance when I tried to use "lexgen.sml". I tried on two Suns, both taking appr. 25 to 28 minutes to evaluate "lexgen.sml". The maximum heap was about 16 MB. The process was so huge that the system speeded donw and I had to kill it in most cases. And once other user even could not run latex within emacs. I want to know whether it is usual. If not, it's caused by ML or "lexgen.sml"? Thank you to your attention to this. Your prompt reply will be appreciated. Status: fixed in 0.89 ---------------------------------------------------------------------- Number: 484 Title: interrupt is buggy (same as 511, 518) Keywords: Submitter: Mike Crawley Date: 10/29/91 Version: 0.73 System: Sparc/SunOS Severity: major Problem: I have been able to repeat the following bug a number of times. Pressing ^C to interrupt sml while it is busy can sometimes crash it. The saved image I was using was 10MB at the time. ^C SIGEMT not related to gc (bogus test: 0x9de3bfc0 @ 0x9dd8) Transcript: Comments: This is a very mysterious bug that has been around for a while. The "0x9de3bfc0 @ 0x9dd8" means that the signal handler received a SIGEMT signal with the PC = 0x9dd8 and the instruction at that address being "save %sp,-0x40,%sp." Under my reading of the documentation, this should never occur in SunOS. The address 0x9dd8 is interesting, since it is the address of an assembly routine used to force a GC trap after a signal (such as ^C), but I don't understand how the sigcontext program counter gets that value. [John Reppy] Status: fixed in 109.21 (probably) ---------------------------------------------------------------------- Number: 485 Title: structure manipulation bombs Keywords: Submitter: Tim Freeman Date: 10/31/91 Version: 0.74 System: Sun 4 running some version of Mach Severity: minor Problem: With some manipulations of structures, raising unhandled exceptions causes SML to bomb. Code: bug3.sml contains: structure Util = struct exception Bug of string end structure InstProto = struct structure U = Util structure S = struct end end open InstProto ; raise U.Bug "hi" Transcript: % sml Standard ML of New Jersey, Version 0.74, 10 October, 1991 Prerelease version. Arrays have changed; see doc/NEWS val it = () : unit - use "bug3.sml"; [opening bug3.sml] structure Util : sig exception Bug of string end structure InstProto : sig structure S : ... structure U : ... end open InstProto SIGILL code 0x7 % Comments: Earlier during the process of narrowing down this bug, it was saying uncaught exception random binary garbage (except you have to imagine the string "random binary garbage" replaced by random binary garbage) instead of getting the SIGILL trap. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 486 Title: Regbind exception (same as bug 380?) Keywords: Submitter: jont@harlqn.co.uk Date: 31/10/91 Version: SML of NJ version number, 0.66 System: Sun 4/330 with SunOS 4.1.1 Severity: critical Problem: The code generation phase blows up with an uncaught exception Regbind Code: (* _testreals.sml the functor (used to be) *) (* Copyright (c) 1991 Harlequin Ltd. *) fun div2 _ = let val new_y = if 0 mod 2 = 0 then "0" else chr(ord "0" + 1) in div2 [] end Transcript: sml66 Standard ML of New Jersey, Version 0.66, 15 September 1990 val it = () : unit - use"../main/_testreals.sml"; [opening ../main/_testreals.sml] [closing ../main/_testreals.sml] uncaught exception Regbind Comments: This is the second time I have encountered this problem. The first time I was unable to produce a small example, and it later went away for reasons which were never clear. However, this time it cropped up in a functor which was only 80 lines at the time, and I was able to whittle it down to the above rather useless function. Probably same as bug #380. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 487 Title: clumsy memory exhaustion Keywords: Submitter: Andy Koenig Date: 11/7/91 Version: 0.74 System: Sparc Severity: minor Problem: SML-NJ is not very nice about handling memory exhaustion. Transcript: [boojum] sml Standard ML of New Jersey, Version 0.74, 10 October, 1991 Prerelease version. Arrays have changed; see doc/NEWS val it = () : unit - fun f x = f(0::x); val f = fn : int list -> 'a - f nil; [Increasing heap to 3164k] [Increasing heap to 4452k] [Increasing heap to 5456k] [Major collection... [Increasing heap to 8192k] 76% used (3427160/4508104), 2610 msec] [Increasing heap to 13192k] [Major collection... 49% used (4497848/8999168), 4600 msec] [Increasing heap to 26380k] [Major collection... 49% used (8999168/18002072), 9250 msec] [Increasing heap to 27204k] [Major collection... [Increasing heap to 27620k] [Increasing heap to 27776k] [Increasing heap to 27860k] [Increasing heap to 27880k] Warning: can't increase heap Ran out of memory[boojum] Comments: Identical to bug 454. While I do ultimately expect some kind of drastic termination, I do **NOT** expect to be unceremoniously dumped out of ML back into the Shell. A more reasonable strategy might be to preallocate a chunk of memory to be used as secondary storage while recovering from exhaustion of primary storage. That, at least, would allow for a return to top level and associated garbage collection, which, in many cases, would allow interactive execution to resume. Incidentally, this example was run on a Sparcstation with 64 megabytes of physical memory and no limit on process size that I know of. I don't know why it gave up the ghost at 28 megabytes -- do you? Owner: Status: open ---------------------------------------------------------------------- Number: 488 Title: wrong types in pervasives Keywords: Submitter: Thomas Yan Date: 8/21/91 Version: 0.71 Severity: minor Problem: bugs in the pervasive environment Transcript: Standard ML of New Jersey, Version 0.71, 23 July 1991 val it = () : unit - Array.tabulate; val it = fn : 'a * (int -> '1b) -> '1b array - String.chr; val it = fn : int -> 'a - Status: fixed in 0.75 ---------------------------------------------------------------------- Number: 489 Title: exportFn image size too large Keywords: Submitter: Andy Koenig Date: 11/17/91 Version: 0.75 System: Sparc Severity: significant Problem: On a Sparc, here's the text and data space used by the executable produced by the following program (with an ML build with noshare): exportFn ("a.out", fn _ => print "Hello world\n"); Version text data 0.66 57344 188416 pre-74 81920 425984 75 81920 294912 Evidently some of the memory leaks in 0.66 have been fixed but not all. Anoither example from John Reppy: (sml-export was made with the -pervshare option) sml-export Standard ML of New Jersey, Version 0.89, September 4, 1992 val it = () : unit - exportFn("foo", fn _ => ()); [Major collection... 25% used (842428/3366736), 430 msec] [Major collection... 66% used (560264/844136), 310 msec] size foo text data bss dec hex 241664 614400 0 856064 d1000 size sml-export text data bss dec hex 241664 3416064 0 3657728 37d000 Fix: Environment refs (pervasiveEnvRef, topLevelEnvRef) were added to Hooks and cleared on export. Changed files boot/perv.sml and boot/system.sig. Status: fixed in 0.94 (0.93c awa,dbm) ---------------------------------------------------------------------- Number: 490 Title: function has bad type in pervasives Keywords: Submitter: Lal Geoge Date: 11/20/91 Version: 0.75 Severity: significant Problem: ceiling has wrong type Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes - ceiling; val it = fn : real -> 'a - Status: fixed in 0.76 ---------------------------------------------------------------------- Number: 491 Title: memory leak Keywords: Submitter: Nevin Heintze (nch@cs.cmu.edu) Date: 11/20/91 Version: 0.75 System: sparc1, pmax, sun3 Mach 2.6 #5.1(CS8f): Wed Sep 11 14:39:14 EDT 1991; CS8/STD+WS Severity: major Problem: garbage collection when rebuilding structures (stuff in old structures does not seem to be reclaimed). Code: signature MEM_HOG = sig val X : int Array.array end functor Mem_hog() : MEM_HOG = struct val X = Array.array(200000, 42) end structure Mem_hog : MEM_HOG = Mem_hog(); open Mem_hog; structure Mem_hog : MEM_HOG = Mem_hog(); open Mem_hog; (* etc... (Following transcript uses 8 functor applications) *) Transcript: Script started on Wed Nov 20 13:54:15 1991 [alonzo] % sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "mem.sml"; [opening mem.sml] [Increasing heap to 3174k] signature MEM_HOG = sig val X : int array end functor Mem_hog : structure Mem_hog : MEM_HOG open Mem_hog [Increasing heap to 3990k] structure Mem_hog : MEM_HOG [Increasing heap to 4094k] open Mem_hog structure Mem_hog : MEM_HOG open Mem_hog [Major collection... [Increasing heap to 6486k] 98% used (2814944/2866068), 1930 msec] [Increasing heap to 10022k] structure Mem_hog : MEM_HOG open Mem_hog structure Mem_hog : MEM_HOG open Mem_hog structure Mem_hog : MEM_HOG open Mem_hog structure Mem_hog : MEM_HOG [Major collection... [Increasing heap to 17126k] 73% used (4412384/6025784), 3670 msec] [Increasing heap to 17646k] open Mem_hog structure Mem_hog : MEM_HOG open Mem_hog [closing mem.sml] val it = () : unit - [alonzo] % exit script done on Wed Nov 20 13:54:43 1991 Comments: I have been running into this problem for a while now in some program analysis implementation work, but was not sure where the problem was. After about 3-4 rebuilds of my system I usually have to start another core image. The general problem occurs on sparc, sun4 and pmax machines; the specific code given above has been tried on a sparc (24MB) and a pmax (64MB?). If the "open Mem_hog" is removed, then the problem goes away. The problem is not specific to arrays; for example if X is bound to a list of a couple of thousand elements instead of an array, then similar behaviour occurs. Status: fixed in 0.89 ---------------------------------------------------------------------- Number: 492 Title: compiler bug from sharing Keywords: Submitter: David Tarditi Date: 7/19/91 Version: 0.70 Severity: major Problem: This code causes a compiler bug in version 0.70. It should be an interesting test case in the future. Code: (* This code shows that we'll need to augment structure instantiation arrays during functor abstraction to include structures which are not in the signature, but which have views that are in the signature. *) signature S0 = sig type u end signature S1 = sig type t val v : t end (* define a structure A, but export only views of A *) functor F1() : sig structure B : S0 structure C : S1 end = struct structure A = struct datatype u = U datatype t = T val v = T end structure B : S0 = A structure C : S1 = A end structure D = F1() (* the definitional sharing constraint implies that C.t = D.C.t, but we won't know this unless we keep the origin of D.B around.*) functor F2(A : sig structure C : S1 sharing D.B = C end) : sig val v : A.C.t end = struct val v = D.C.v end Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 493 Title: Compiler bugs from bad include specs Keywords: Submitter: Bruce Esrig Date: 7/19/91 Version: ? Severity: major Problem: Compiler bug from include specs Code: (* Sigs.sml -- experiment with signatures and sharing *) (* this is accepted *) signature X' = sig datatype 'a Opt = None | Some of 'a end signature Y' = sig datatype 'a Opt = None | Some of 'a end signature Z' = sig include X' include Y' end; (* this fails *) signature X' = sig datatype 'a Opt = None | Some of 'a end signature Y' = sig include X' end (* signature Z' = sig include X' include Y' end *) (* std_in:0.0 Compiler Bug: Signs.abstractSig.abstractType 2 *) (* signature W' = sig include X' include Y' sharing type X'.Opt = Y'.Opt end *) (* std_in:0.0 Compiler Bug: Signs.abstractSig.abstractType 2 *) signature X' = sig type opt end signature Y' = sig type opt end (* signature Z' = sig include X' include Y' sharing type X'.opt = Y'.opt end *) (* std_in:2.20-2.70 Error: unbound structure id in sharing specification: X' *) (* How do I build a signature which brings a shared type to top level? *) signature Z' = sig structure X : X' structure Y : Y' sharing type X.opt = Y.opt open X end structure Z : Z' = struct structure X = struct type opt = int end structure Y = struct type opt = int end open X end; (* structure Z : sig structure X : sig...end structure Y : sig...end end *) (* 5 : Z.opt; *) (* std_in:10.5-10.9 Error: unbound type in structure: opt *) Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 494 Title: bogus gc message Keywords: Submitter: Bob Harper Date: 12/16/91 Version: 0.75 Severity: minor Problem: negative number in "[Increasing heap to -12217k]" message Transcript: [reading .../front/printback.sml] [Major collection... [Increasing heap to 8110k] [Increasing heap to 7942k] [Increasing heap to 7438k] [Increasing heap to 5926k] [Increasing heap to 1390k] smlsg: could not sbrk, return = 1 [Increasing heap to -12217k] *** NB 48% used (2767236/5647472), 2570 msec] [Increasing heap to 8270k] [writing .../.@sys/printback.sml.bin... done] [closing .../front/printback.sml] Status: obsolete -------------------------------------------------------------------- Number: 495 Title: inaccurate emacs info file Keywords: Submitter: dan@math.uiuc.edu Date: 12/26/91 Version: 75 Severity: minor Problem: From the IO node in the emacs info file "sml" val execute : string -> instream * outstream From the program - execute; val it = fn : string * string list -> instream * outstream Fix: edit the file "sml" to give the correct declaration for "execute" Status: fixed in 0.76 (in /usr/local/sml/75/lib/emacs/info/sml) ---------------------------------------------------------------------- Number: 496 Title: incorrect defn of dec in fastlib Keywords: Submitter: Stephen Adams, S.R.Adams@ecs.soton.ac.uk Date: 1/3/92 Version: 0.75 Severity: curiosity Problem: Curious code in compiler source I have been looking in the compiler source and I discovered a small bug: Code: (* cpsopt.sml * * Copyright 1989 by AT&T Bell Laboratories *) functor CPSopt(val maxfree : int) : sig val reduce : CPS.function * System.Unsafe.object option * bool -> CPS.function end = struct structure Fastlib = struct structure Ref = struct open Ref fun inc r = r := !r + 1 fun dec r = r := !r + 1 (* this is the worrying bit!*) end Comment: dec is used but only in the function `unescapeargs'. I guess that it should be fixed before it causes any grief. Status: fixed in 0.75 ---------------------------------------------------------------------- Number: 497 Title: ML-Yacc doesn't open Array Keywords: Submitter: Lie Ma, ma@cs.pdx.edu Date: 12/26/91 Version: SML Ver.77 System: SUN Sparc Code: base.sml Encl: typescript Problem: Error found when loading base.sml, while no problem using SML Ver.66. Or, is there new version of smlyacc corporated with the new version of SML? ---------------------- Typescript ---------------------- Script started on Thu Dec 26 22:45:01 1991 warning: could not update utmp entry antares% cat makepaqrser.sml" "; Unmatched ". antares% cat makeparser.sml (* ------------------------ FILE: makeparser.sml ---------------------------- Author: Lie Ma 12/10/1991 Usage: Call the files "spec.grm.sig", "spec.grm.sml" (generated by "smlyacc.sml" according to "spec.grm") and "spec.lex.sml" (gnerated by "lexgen.sml" according to "spec.lex"). Then use structure "SpecLrVals", "SpecLex" and "SpecParser" to generate the parser. Call: spec.grm.sig, spec.grm.sml, spec.lex.sml Input: nothing Output: parser -------------------------------------------------------------------------- *) use "YACC/base.sml"; (* laod the common modules *) use "spec.grm.sig"; (* load grammar signature file *) use "spec.lex.sml"; (* load lexer program file *) use "spec.grm.sml"; (* load grammar program file *) (* --------- define structures ------------ *) structure SpecLrVals = SpecLrValsFun(structure Token = LrParser.Token); structure SpecLex = SpecLexFun(structure Tokens = SpecLrVals.Tokens); structure SpecParser = Join(structure ParserData = SpecLrVals.ParserData structure Lex=SpecLex structure LrParser=LrParser); (* ----------- function parse to read file and parse it -------------- *) val parse = fn s => let val dev = open_in s val stream = SpecParser.makeLexer(fn i => input(dev,i)) val _ = SpecLex.UserDeclarations.pos:=1 val error = fn(e,i: int,_) => output(std_out, s ^ "," ^ " line "^ (makestring i) ^ ", Error: " ^ e ^ "\n") in SpecParser.parse(30,stream,error,()) before close_in dev end val keybd = fn () => let val dev = std_in val stream = SpecParser.makeLexer (fn i => input_line dev) val _ = SpecLex.UserDeclarations.pos:=1 val error = fn(e,i: int,_) => output(std_out, "std_in, line "^ (makestring i) ^ ", Error: " ^ e ^ "\n") in SpecParser.parse(0,stream,error,()) end antares% sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - " use "makeparser.sml"; [opening makeparser.sml] [opening YACC/base.sml] signature STREAM = sig type 'a stream val streamify : (unit -> '1a) -> '1a stream val cons : '1a * '1a stream -> '1a stream val get : '1a stream -> '1a * '1a stream end signature LR_TABLE = sig datatype state con STATE : int -> state datatype term con T : int -> term datatype nonterm con NT : int -> nonterm datatype action con ACCEPT : action con ERROR : action con REDUCE : int -> action con SHIFT : state -> action type table val numStates : table -> int val describeActions : table -> state -> (term * action) list * action val describeGoto : table -> state -> (nonterm * state) list 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) list * action) list,gotos:(nonterm * state) list list,initialState:state,numStates:int} -> table end signature TOKEN = sig structure LrTable : ... datatype ('a,'b) token con TOKEN : LrTable.term * ('a * 'b * 'b) -> ('a,'b) token val sameToken : ('a,'b) token * ('a,'b) token -> bool end signature LR_PARSER = sig structure Stream : ... structure LrTable : ... structure Token : ... exception ParseError val parse : {arg:'a,ec:{error:string * '1c * '1c -> unit,errtermvalue:LrTable.term -> '1b,is_keyword:LrTable.term -> bool,noShift:LrTable.term -> bool,preferred_insert:LrTable.term -> bool,preferred_subst:LrTable.term -> LrTable.term list,showTerminal> :LrTable.term -> string,terms:LrTable.term list},lexer:('1b,'1c) Token.token Stream.stream,lookahead:int,saction:int * '1c * (LrTable.state * ('1b * '1c * '1c)) list * 'a -> LrTable.nonterm * ('1b * '1c * '1c) * (LrTable.state * ('1b * '1c * '1c)) list,ta> ble:LrTable.table,void:'1b} -> '1b * ('1b,'1c) Token.token Stream.stream sharing Token.LrTable = LrTable end signature LEXER = sig structure UserDeclarations : ... val makeLexer : (int -> string) -> unit -> (UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token end signature ARG_LEXER = sig structure UserDeclarations : ... val makeLexer : (int -> string) -> UserDeclarations.arg -> unit -> (UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token end signature PARSER_DATA = sig type pos type svalue type arg type result structure LrTable : ... structure Token : ... structure Actions : ... structure EC : ... val table : LrTable.table sharing LrTable = Token.LrTable end signature PARSER = sig structure Token : ... structure Stream : ... exception ParseError type pos type result type arg type svalue val makeLexer : (int -> string) -> (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 signature ARG_PARSER = sig structure Token : ... structure 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 structure Stream : STREAM YACC/base.sml:340.14-340.16 Error: unbound variable or constructor sub YACC/base.sml:342.10-342.25 Error: operator and operand don't agree (tycon mismatch) operator domain: 'Z array operand: error -> int -> 'Y in expression: length a YACC/base.sml:342.26 Error: overloaded variable "-" cannot be resolved YACC/base.sml:395.36-395.38 Error: unbound variable or constructor sub YACC/base.sml:395.28-395.45 Error: operator is not a function operator: (int array * int) array in expression: action bogus YACC/base.sml:402.26-402.28 Error: unbound variable or constructor sub YACC/base.sml:402.20-402.35 Error: operator is not a function operator: int array array in expression: goto bogus YACC/base.sml:409.45-409.47 Error: unbound variable or constructor sub YACC/base.sml:421.53-421.55 Error: unbound variable or constructor sub YACC/base.sml:418.27-418.48 Error: operator and operand don't agree (tycon mismatch) operator domain: 'Z array operand: error -> int -> int in expression: length row YACC/base.sml:421.40-421.62 Error: operator is not a function operator: (int array * int) array in expression: action bogus YACC/base.sml:418.46 Error: overloaded variable "-" cannot be resolved YACC/base.sml:427.29-427.31 Error: unbound variable or constructor sub YACC/base.sml:431.49-431.51 Error: unbound variable or constructor sub YACC/base.sml:427.14-427.37 Error: operator is not a function operator: int array array in expression: goto bogus YACC/base.sml:447.5-447.15 Error: unbound variable or constructor arrayoflist YACC/base.sml:449.5-449.15 Error: unbound variable or constructor arrayoflist YACC/base.sml:450.17-450.27 Error: unbound variable or constructor arrayoflist YACC/base.sml:453.14-453.24 Error: unbound variable or constructor arrayoflist [closing YACC/base.sml] [closing makeparser.sml] - ^Dantares% ^D script done on Thu Dec 26 22:46:17 1991 Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 498 Title: bad function type in perv.sig Keywords: Submitter: Embden Gansner Date: 1/7/92 Version: ? Severity: significant Problem: The BITS signature in perv.sig should have val notb : int -> int instead of val notb : int * int -> int Status: fixed in 0.81 ---------------------------------------------------------------------- Number: 499 Title: execute broken Keywords: Submitter: David Spooner (spoonerd@.cpsc.ucalgary.ca) Date: 1/7/92 Version: 0.75 System: ? Severity: major Problem: No output availabe from execute. Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () :unit - val (instr,outstr) = execute ("ls", []); val instr = - :instream val outstr = - :outstream - input (instr, 5); val it = "" :string - can_input instr; val it = 0 :int Fix: (luochen@shade.Princeton.EDU (Luoqi Chen)) I believe the problem is in the runtime routine, ml_exec(), it calls execve(2) instead of execvp(3), so it won't look up in the PATH for the command. Try "/bin/ls" instead. The fix is simple, change the line (line 1238 of src/runtime/cfuns.c) execve (cmd, argv, envp); to { extern char **environ = envp; execvp(cmd, argv);} Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 500 Title: memory leak Keywords: Submitter: Kjeld H. Mortensen, metasoft!kjeld@uunet.UU.NET, (617) 576.6920 x 22 Date: 1/7/92 Version: 0.75 System: SUN OS 4.1.1, ram 32Mb, swap 103Mb, and HPUX 8.0, ram 32Mb, swap 70Mb. Severity: major Problem: During use of the extended compiler we see a significant slowdown of this process when using v0.75 of SML/NJ (a factor 2 over a time period of 15 minutes reasonable heavy use, and doesn't seem to stop there). Observations: 1) We see absolutely no slow down when using v0.62 of SML/NJ on the Sun4 (haven't been able to succesfully compile this version on the HP9000 though). 2) We see significant slow down when using v0.75 of SML/NJ on both the Sun4 and HP9000. (In spite of the slow down, the compiler process gets more and more CPU-time.) 3) Since we use the same ML-code in both cases 1) and 2), I'm lead to conclude that it must be a problem in the SML/NJ system v0.75. Example: Unfortunately I haven't been able to reproduce the phenomenon for a reasonable small example. Followup: >...By the way, is your slow-down program mostly compiling things, or executing >compiled code? It is mostly executing compiled code. I made some further investigations regarding the heap size. Each of the experiments performed, make up the same amount of work for the ML process (work is measured in units of what I call "steps"). In the following table, "MEM-INC" is calculated using numbers from the first and the last major collection. Let the output from the two major collections have the format: [Major collection... % used (/), msec] [Major collection... % used (/), msec] The numbers in "MEM-INC" then have the format: -/-, "/" not to be confused with division. The numbers in "Work" are only there to show that the compiler in each experiment, did the same amount of computations. Machine configurations: Sun4 , SUN OS 4.1.1, ram 32Mb, swap 103Mb, and HP9000s400, HPUX 8.0 , ram 32Mb, swap 70Mb. Machine | SML/NJ | Work/steps | MEM-INC/bytes | Number of major coll. -----------+--------+------------+---------------+---------------------- Sun4 | v0.62 | 203 | 18292/179960 | 4 Sun4 | v0.75 | 201 | 425120/926324 | 12 HP9000s400 | v0.75 | 202 | 517352/931376 | 40 Comment: [dbm] This was probably fixed by restoring environment cleanup (in 0.82). Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 501 Title: out of date yacc example code Keywords: Submitter: Andy Koenig Date: 1/11/92 Version: ? Severity: minor Problem: The calc.grm.sig, calc.grm.sml, and calc.lex.sml file in mlyacc/examples/calc needs to be updated. Rerun ml-yacc and ml-lex on the appropriate files. Fix: In the calc directory are the following files: README calc.grm calc.grm.desc calc.grm.sig calc.grm.sml calc.lex calc.lex.sml join.sml load.sml Saying sml-lex calc.lex rebuilds calc.lex.sml; saying sml-yacc calc.grm rebuilds calc.grm.* That should be done in the distribution directories so that people will get the right versions. [from Dave Tarditi:] The directory tools/mlyacc/examples contains some files which need to be regenerated by the new versions of the parser and lexer generator. You need to regenerate the files examples/calc/calc.grm.sml, examples/calc.lex.sml by running the parser generator on calc.grm and the lexer generator on calc.lex. Please remove the file examples/fol/fol.lex.sml. Status: fixed in 0.91 (Tarditi) ---------------------------------------------------------------------- Number: 502 Title: zombie sml processes Keywords: Submitter: Stephen Adams Date: 1/13/92 Version: 0.66, 0.75 System: SunOS 4.1, sparc Severity: minor Problem: SML processes don't die if you log out Code: any running sml process Comment: We use NJ-SML for teaching and research. A common problem is if a user logs out (by selecting `exit' in X-windows, for example) the sml proces doesnt die, but sits there consuming cpu cycles (often > 40% of the cpu time). With a large number of naive users this is a serious problem. Even `sophisticated' users sometimes accidentally slug a machine for a few days. It would be much friendlier to the community if an SML process running (foreground under a shell) under Xterm or under emacs would die when the user exits from X-windows or suntools. Comment: [JHR] I was unable to reproduce this. Perhaps there setup is such that a SIGHUP isn't getting generated. >Date: 05-Aug-93 >Version: 0.93 >System: SunOS 4.1.3, sparc, X11R5 >Problem: SML processes don't die if you log out >Code: any running sml process Because SML/NJ will used in our beginners' courses starting in october, this seems to be a serious bug (just as S.Adams wrote). To reproduce, I just 1. open a new xterm window (`tty` gives /dev/ttypa) 2. start smld 3. start 'top' in another window: PID USERNAME PRI NICE SIZE RES STATE TIME WCPU CPU COMMAND 10161 sk 1 0 8752K 4308K sleep 0:04 14.48% 9.38% smld 4. 'destroy' the sml-xterm via twm, wait a few minutes 5. look into 'top' or 'ps x': PID USERNAME PRI NICE SIZE RES STATE TIME WCPU CPU COMMAND 10161 sk 1 0 8752K 96K sleep 0:04 0.00% 0.00% smld PID TT STAT TIME COMMAND 10161 pa S 0:04 sml Note: the process still has tty pa. Only a 'kill -9' can remove the process. Could you please tell us what to do? Mr. Adams' argumentation applies to us, too. Tschau Stefan Stefan Kirchberg sk@irb.informatik.uni-dortmund.de Computer Science Department - IRB Tel. from inside UniDO: 4700 University of Dortmund from outside: 0231/755-2422 44221 Dortmund, Germany Office: GB V/R.325 Owner: John Status: fixed in 109.21 [new runtime] ---------------------------------------------------------------------- Number: 503 Title: illegal instruction -- core dumps Keywords: Submitter: Markus Freericks mfx@cs.tu-berlin.de Date: 1/28/92 Version: 0.75 System: Sparc 2 (4/50), 16M, SunOS Severity: Major, at least for me Problem: When running my compiled program, sml encounters an "illegal instruction" and dumps core. When the program is interpreted, there is a message ----------------------------------------------------------------------------- Error: Compiler bug: no default in interp ----------------------------------------------------------------------------- the bug seems to occur in a totally normal case expression. I am currently trying to isolate the error, but would like to know whether there is some special thing to look for. I use an sml image that contains the full Edinburgh library; the code that dumps core is part of the semantic rules of a parser written in sml-yacc. The code is heavy with functionals. Just to get an idea of what the code looks like, the function where the error occurs is ----------------------------------------------------------------------------- fun makeParamDecl(oflag:bool,headId:S.T,(id,arglists:((S.T * Texpr) list list)),body : Texpr)= fn {env=E} => let fun loop ([]:(S.T*Texpr)list list,comb:ACexpr->ACexpr,env) = let val {free=f,used=u,expr=e} = body {env=env} in {defs = [id], expr = {free=f, used=u, expr=comb(e) }} end | loop (args::argss,comb,env) = let (* rename the parameters if necessary *) val params = map #1 args val typtexprs = map #2 args val typacterms= map (fn x => x {env=env}) typtexprs val typcterms = map (fn x => (output(std_out,"mpdloop1\n"); (case x of (Complex(_)) => output(std_out,"complex\n") | (Atomic(_)) => output(std_out,"atomic\n")); output(std_out,"mpdloop2\n"); (case x of Atomic(X) => X | Complex(Y)=> (output(std_out,"error: type var must be atomic:\n"); Cterm.print std_out (Y objVar); objVar)) )) typacterms val renames = renameSyms env params val env' = Env.addList (ListPair.zip(params,renames)) env val env''= putNewEE(putNewState(env)) val k = S.gen("_k") fun comb' x = comb(Atomic(C.Lambda((ListPair.zip(renames,typcterms))@ [(k,objVar), (getEE env'',objVar), (getState env'',objVar)], applyK(x,C.Var(k),env'')))) in loop(argss,comb',env') end in loop(arglists,(fn x=>x),E) end Comment: when called, "mpdloop1" gets printed, then the error message appears. This is independent of the value of "x" (Atomic of Complex). As I said, am trying to reduce the error-generating code to manageable size and send that to you, but that may take a while. Status: fixed in 0.75 ---------------------------------------------------------------------- Number: 504 Title: Another core dump Keywords: Submitter: Markus Freericks mfx@cs.tu-berlin.de Date: 1/28/92 Version: 0.75 System: Sparc 2 (4/50), 16M, SunOS Severity: Major, at least for me This is a followup to my earlier message. The following code dumps core on my machine, even though it is interpreted! (I hadn't got the nerve to reduce it any further, because startup-time for sml on this system is in the order of 30 seconds) Code: SML_NJ.Control.interp :=true; structure Symbol=Int signature CTERM = sig datatype CONV = Check | Cast datatype T = Var of Symbol.T | Const of String.T | Apply of T list val print : outstream -> T -> unit end structure Cterm : CTERM = struct datatype CONV = Check | Cast datatype T = Var of Symbol.T | Const of String.T | Apply of T list fun indStringList indent = fn Var(x) => [(indent,"var")] | Const(s) => [(indent,"const")] | Apply(args) => (List.foldR' (fn a => fn b => a @ b) (map (fn (expr) => (indStringList (indent+1) expr)) args)) fun print os x = ((indStringList 1 x);()) end structure B = struct structure S = Symbol structure SS = Int structure C = Cterm type Env = bool datatype ACexpr = Atomic of C.T | Complex of C.T -> C.T type TexprResult = {free:SS.T,used:SS.T,expr:ACexpr} type Texpr = {env:Env} -> TexprResult fun mkDummyExpr(x) : Texpr = fn {env=E} => {free = 1 , used = 2 , expr = Atomic(C.Const("\"dummyE:"^x^"\""))} val dummyExpr = mkDummyExpr("") val objVar = C.Var(1) fun makeParamDecl((id,arglists:((S.T * Texpr) list list)),body : Texpr)= fn {env=E} => let fun loop ([],comb:ACexpr->ACexpr,env) = let val {free=f,used=u,expr=e} = body {env=env} in {defs = [id], expr = {free=f, used=u, expr=comb(e) }} end | loop (args::argss,comb,env) = let (* rename the parameters if necessary *) val params = map #1 args (* typcon mismatch if *) (* commented out *) val typtexprs = map (fn (a,b)=>b) args val typacterms= map (fn x => x {env=env}) typtexprs (* typacterms=[Atomic(objVar)] would be ok *) (* [] instead of typtexprs would be ok,too *) val _ = output(std_out,"makeParamDecl-2\n") val typcterms = map (fn x => (output(std_out,"mpdloop1\n"); (*XXXX*) (case x of (Complex _) => output(std_out,"complex\n") | (Atomic _) => output(std_out,"atomic\n")); output(std_out,"mpdloop2\n"); (case x of Atomic(X) => ( (*this here print causes the error!*) Cterm.print std_out X; X) | Complex(Y)=> (output(std_out,"error: type var must be atomic:\n"); Cterm.print std_out (Y objVar); objVar)) )) typacterms val _ = output(std_out,"makeParamDecl-5\n") in loop(argss,comb,env) end in loop(arglists,(fn x=>x),E) end end; val xx = B.makeParamDecl((12, [[(1,B.dummyExpr)]]), B.dummyExpr ); fun killMe() = xx({env=true}) (* calling killMe results in a bus error *) killMe() Comment: The main problem seems to be the type error at (*XXXX*): "typtexprs" is of type "Texpr", so "typacterms" is a "TexprResult", not an "ACterm", as assumed by the "case x of Atomic...". This being undetected, a runtime error follows quite naturally. Funny enough, if the "Apply" clause in "indStringList" is removed by some simple rhs that doesn't inspect the argument of the Apply, no runtime error occurs. PS. After having found the type error, the function runs fine. Guess that makes the Severity "minor, at least for me". Status: fixed in 0.75 ---------------------------------------------------------------------- Number: 505 Title: bad datatype definition accepted Keywords: Submitter: John Reppy Date: 1/28/92 Version: 0.76 Severity: minor Problem: The following is not legal SML (cf. Definition, sec 2.9), but is accepted by the compiler: Transcript: Standard ML of New Jersey, Version 0.76, December 14, 1991 Arrays have changed; see Release Notes val it = () : unit - datatype foo = FOO of int | BAR and bar = BAR; datatype foo con BAR : foo con FOO : int -> foo datatype bar con BAR : bar Status: fixed in 0.91 (dbm) ---------------------------------------------------------------------- Number: 506 Title: Runbind exception Keywords: Submitter: Thomas M. Breuel Date: 1/31/92 Version: 0.75 System: SparcStation IPC SunOS 4.1.1 Severity: major (?) Problem: code dies with "uncaught exception Runbind" when put into "structure All" Code: local type time = System.Timer.time val timeofday : unit -> time = System.Unsafe.CInterface.c_function "timeofday" in fun timeit f = let open System.Timer val t = start_timer() val rt = timeofday() val z = f () val rt' = sub_time(timeofday(),rt) val t' = check_timer t val ts = check_timer_sys t val tg = check_timer_gc t in print(implode["user: ",makestring t', " gc: ", makestring tg, " system: ",makestring ts, " real: ",makestring rt',"\n"]); z end end; structure All = struct signature RA2 = sig exception Subscript type array val array : (int * int) * real -> array val dim : array * int -> int val sub : array * (int * int) -> real val update : array * (int * int) * real -> unit end; structure X:RA2 = struct structure R = RealArray exception Subscript = R.RealSubscript datatype array = A of (int * int) * R.realarray fun array((d0,d1),initial) = A((d0,d1),R.array(d0*d1,initial)) fun dim(A((d0,d1),_),0) = d0 | dim(A((d0,d1),_),1) = d1 | dim _ = raise Subscript fun sub(A((d0,d1),a),(i,j)) = R.sub(a,i*d1+j) fun update(A((d0,d1),a),(i,j),v) = R.update(a,i*d1+j,v) end; structure Y:RA2 = struct structure R = RealArray structure A = Array exception Subscript = R.RealSubscript (*HACK*) type array = R.realarray A.array fun dim(a,0) = A.length(a) | dim(a,1) = R.length(A.sub(a,0)) | dim _ = raise Subscript fun array((d0,d1),initial) = A.tabulate(d0,fn j => R.array(d1,initial)) fun sub(a,(i,j)) = R.sub(A.sub(a,i),j) fun update(a,(i,j),v) = R.update(A.sub(a,i),j,v) end; functor Test(A2:RA2) = struct fun dotimes(n,f) = let fun loop(i) = if i>=n then () else (f(i); loop(i+1)) in loop(0) end fun foldtimes(n,r,f) = let fun loop(i,r) = if i>=n then r else loop(i+1,f(r,i)) in loop(0,r) end fun a before b = a fun fold(a,r,f) = foldtimes(A2.dim(a,1),r,fn (r,y) => foldtimes(A2.dim(a,0),0.0,fn (r,x) => (f(r,A2.sub(a,(x,y)))) before (A2.update(a,(x,y),r)))) fun bound(x) = if x>=1.0 then bound(x-1.0) else x fun combine(x,y) = bound(x*1.17812+y) fun doit() = let val w = 512 val h = 512 val a = A2.array((w,h),0.0001) in dotimes(2,fn i => fold(a,0.0,combine)) end val _ = timeit(doit) end; end; open All; Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - [opening compare.sml] val timeit = fn : (unit -> 'a) -> 'a compare.sml:25.1-33.7 Warning: signature found inside structure or functor compare.sml:62.1-92.7 Warning: functor found inside structure or functor structure All : sig signature RA2 = sig exception Subscript type array val array : (int * int) * real -> array val dim : array * int -> int val sub : array * (int * int) -> real val update : array * (int * int) * real -> unit end functor Test : structure X : RA2 structure Y : RA2 end open All [closing compare.sml] val it = () : unit - structure Dummy = Test(X); uncaught exception Runbind - Comments: This seems to be different from the bugs relating to Runbind in the masterbugs list (all of those claim to have been fixed or claim to be unreproducible). Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 507 Title: most negative integer causes compiler bug (see also 630, 632) Keywords: Submitter: Thomas Yan (tyan@cs.cornell.edu) Date: 2/3/92 Version: 0.75? Severity: minor Problem: Sometimes the compiler has problems with the most negative integer: Transcript: fun f ~0x40000000 = 7; std_in:1.1-1.21 Warning: match not exhaustive ~1073741824 => ... Error: Compiler bug: Overflow in cps/generic.sml - Status: fixed in 0.90 ---------------------------------------------------------------------- Number: 508 Title: xorb Keywords: Submitter: Thomas Yan (tyan@cs.cornell.edu) Date: 2/3/92 Version: 0.75? Severity: minor Problem: xorb gives wrong answer Transcript: - fun f x = x xorb ~0x40000000; val f = fn : int -> int - f 0; val it = uncaught exception Boxity - fun f x = x xorb ~0x40000000; val f = fn : int -> int - f 0; val it = ~1073741824 : int - Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 509 Title: compiler bug in number pattern Keywords: Submitter: Thomas Yan (tyan@cs.cornell.edu) Date: 2/3/92 Version: 0.75? Severity: minor Problem: Compiler bug in hexidecimal pattern Transcript: - fun f 0x3fffffff = 2; std_in:3.1-3.20 Warning: match not exhaustive 1073741823 => ... Error: Compiler bug: Overflow in cps/generic.sml Comment: After looking at cps/generic.sml, I think the problem is with generating code with immediate data. Often, things like (INT u) op v get translated into (immed (u+u)) v, where the u+u is for the boxity scheme (the +1 comes from v). But when u is already near the limit, then u+u overflows. Obviously, it would be nice for this to get fixed. Status: fixed in 0.90 ---------------------------------------------------------------------- Number: 510 Title: poor error message in ml-lex (same as 475) Keywords: Submitter: Reppy Date: 2/1/92 Version: 0.75? Severity: minor? Problem: The following lex file %% special = [@#$%^&*_+=|\\/<>-]; %% \n => (inc ln; lex()); produces ? sml-lex: uncaught exception LOOKUP Comments: I believe this is because there are special characters in the [...], but this is a poor error message. Status: same as 475 ---------------------------------------------------------------------- Number: 511 Title: dying on interupt with SIGEMT (same as 484, 518) Keywords: Submitter: tmb@ai.mit.edu (Thomas M. Breuel) Date: 1/14/92 Version: 0.75 System: SunOS 4.1.?, Sparc IPC Severity: major Problem: When typing Control-C, the system dies with a SIGEMT Code: (this doesn't seem to be specific to any code) Transcript: - trymatches(model,image,BoundedMatch.eval,5.0,10.0,0.4); ((17.0,11.0),(222.0,175.0)) ((5.0,5.00028),(552.0,473.0)) ((~217.0,~169.99972),(535.0,462.0)) ~217.0 ~212.0 SIGEMT not related to gc (bogus test: 0x9de3bfc0 @ 0xa150) Process Inferior mysml exited abnormally with code 3 Comments: This is also given as bug 304 in the "masterbugs" list, but it is not listed in the "openbugs" list anymore. Did this bug come back or was it never fixed? Based on the PC info, this was probably an OS bug. Changes to the GC invocation mechanism mean that it is moot. -- JHR Status: fixed in 0.93 ---------------------------------------------------------------------- Number: 512 Title: compiler looping Keywords: Submitter: tmb@ai.mit.edu Date: 1/15/92 Version: 0.75 (loaded+dumped mylib) System: SunOS 4.1.?, Sparc IPC Severity: major Problem: compiling the red-black tree code below inside the "structure ... = struct ... end" fills up memory and doesn't seem to terminate; compiling at top-level works fine Code: (* Red-Black Trees *) signature ODICT = sig type 'a Dict val lookup : ('a -> 'b) * ('b * 'b -> bool) * 'a Dict * 'b -> 'a val insert : ('a -> 'b) * ('b * 'b -> bool) * 'a Dict * 'a -> 'a Dict val aslist : 'a Dict -> 'a list end; structure RBTree:ODICT = struct datatype Color = Rd | Bl datatype 'a Node = ND of Color * 'a * 'a Node * 'a Node | LEAF; type 'a Dict = 'a Node fun aslist(LEAF) = [] | aslist(ND(c,k,l,r)) = aslist(l) @ k @ aslist(r) exception Lookup fun lookup(key,less,LEAF,k) = raise Lookup | lookup(key,less,ND(_,v,l,r),k) = if less(k,key(v)) then lookup(key,less,l,k) else if less(key(v),k) then lookup(key,less,r,k) else v fun rewrite(ND(Bl,B,ND(Rd,A,alpha,beta),ND(Rd,C,gamma,delta))) = (ND(Rd,B,ND(Bl,A,alpha,beta),ND(Bl,C,gamma,delta))) | rewrite(ND(Bl,C,ND(Rd,A,alpha,ND(Rd,B,beta,gamma)),delta)) = ND(Bl,B,ND(Rd,A,alpha,beta),ND(Rd,C,gamma,delta)) | rewrite(ND(Bl,C,ND(Rd,B,ND(Rd,A,alpha,beta),gamma),delta)) = ND(Bl,B,ND(Rd,A,alpha,beta),ND(Rd,C,gamma,delta)) | rewrite(ND(Bl,A,alpha,ND(Rd,B,ND(Rd,C,beta,gamma),delta))) = ND(Bl,B,ND(Rd,A,alpha,beta),ND(Rd,C,gamma,delta)) | rewrite(ND(Bl,A,alpha,ND(Rd,B,beta,ND(Rd,C,gamma,delta)))) = ND(Bl,B,ND(Rd,A,alpha,beta),ND(Rd,C,gamma,delta)) | rewrite x = x; fun insert(key,less,v,tree) = let fun insert'(LEAF) = ND(Rd,v,LEAF,LEAF) | insert'(ND(Bl,v',left,right)) = if less(key(v),key(v')) then rewrite(ND(Bl,v',insert'(left),right)) else if less(key(v'),key(v)) then rewrite(ND(Bl,v',left,insert'(right))) else ND(Bl,v',left,right) | insert'(ND(Rd,v',left,right)) = if less(key(v),key(v')) then ND(Rd,v',insert'(left),right) else if less(key(v'),key(v)) then ND(Rd,v',left,insert'(right)) else ND(Rd,v',left,right); val ND(_,v,l,r)=insert'(tree) in ND(Bl,v,l,r) end fun create(key,less,l) = let fun loop([],r) = r | loop(x::xs,r) = loop(xs,insert(key,less,x,r)) in loop(l,LEAF) end; fun id x = x fun lt(x:int,y) = x 'a) * ('a * 'a -> bool) * 'b Dict * 'a -> 'b val insert : ('b -> 'a) * ('a * 'a -> bool) * 'b Dict * 'b -> 'b Dict val aslist : 'a Dict -> 'a list end datatype Color con Bl : Color con Rd : Color datatype 'a Node con LEAF : 'a Node con ND : Color * 'a * 'a Node * 'a Node -> 'a Node type 'a Dict = 'a Node val aslist = fn : 'a list Node -> 'a list exception Lookup val lookup = fn : ('a -> 'b) * ('b * 'b -> bool) * 'a Node * 'b -> 'a val rewrite = fn : 'a Node -> 'a Node redblack.sml:56.3-56.31 Warning: binding not exhaustive ND (_,v,l,r) = ... val insert = fn : ('a -> 'b) * ('b * 'b -> bool) * 'a * 'a Node -> 'a Node val create = fn : ('a -> 'b) * ('b * 'b -> bool) * 'a list -> 'a Node val id = fn : 'a -> 'a val lt = fn : int * int -> bool [closing redblack.sml] val it = () : unit - <--- I've put the structure ... = struct ... end back [opening redblack.sml] signature ODICT = sig type 'a Dict val lookup : ('b -> 'a) * ('a * 'a -> bool) * 'b Dict * 'a -> 'b val insert : ('b -> 'a) * ('a * 'a -> bool) * 'b Dict * 'b -> 'b Dict val aslist : 'a Dict -> 'a list end [Major collection... [Increasing heap to 3420k] [Increasing heap to 3560k] [Increasing heap to 4260k] [Increasing heap to 7760k] 69% used (1952632/2809440), 2100 msec] [Increasing heap to 8192k] [Major collection... 94% used (3980248/4209932), 4600 msec] [Increasing heap to 12344k] [Major collection... [Increasing heap to 18924k] 94% used (6180760/6516556), 7060 msec] [Increasing heap to 19104k] [Major collection... [Increasing heap to 29280k] Process Inferior sml killed <--- kill -9 Comments: BTW, do you have code to delete from persistent red-black trees? It gets really messy... Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 513 Title: not waiting for execute children Keywords: Submitter: Robert S. Thau (rst@ai.mit.edu) Date: 1/20/92 Version: ? Severity: major Problem: SML/NJ appears not to wait for children forked off by execute. This can be a problem in certain circumstances. In my particular case, I wrote a routine which draws graphs for the user by forking off an xplot and sending down plot commands. After fifty graphs or so, the zombie xplots had completely filled my per-user process limit, making it difficult to determine the nature of the problem (ps: cannot fork: no more processes). In this particular case, I'd be more than willing to do the wait myself, but execute gives me no process-id to wait for, just the input and output streams. [from Phil Jeffcock , 3/2/92] I'm running SML/NJ 0.75 on my SUN Sparc IPC. I've been writing an application which I need to use execute frequently and in doing so the ML runtime is creating a zombie process each time I use it. After a short while I run out of process slots. Any ideas? Fix: just before doing the execute, do wait3(&status,WNOHANG,NULL) to clean up previous children, if any. Status: fixed in 0.91 ---------------------------------------------------------------------- Number: 514 Title: uncaught exception ErrorStructure Keywords: Submitter: John Reppy Date: 1/15/92 Version: 0.76 Severity: minor Problem: I got the following uncaught exception when working on my Amber stuff: ... [opening join.sml] join.sml:6.25-6.38 Error: unbound functor: AmberLrValsFun [closing join.sml] [closing load] uncaught exception ErrorStructure - I tried a few small examples, but I wasn't able to reproduce the bug. The offending file ("join.sml") is: structure AmberLrVals = AmberLrValsFun (structure Token = LrParser.Token) structure AmberLex = AmberLexFun (structure Tokens = AmberLrVals.Tokens) structure AmberParser = Join ( structure ParserData = AmberLrVals.ParserData structure Lex = AmberLex structure LrParser = LrParser) If I add a ";" to the first line, then I just get the error message. [from Jon Thackray , 4/8/92]: Ok, here's a stripped down version of the ErrorStructure problem. I don't believe it can get any smaller. The significant factors seems to be twofold, firstly, the missing parameter to the Mir_Utils functor, and secondly the sharing constraint between the parameters of this functor. The first factor in isolation is not sufficient to produce the problem, as far as I can tell. Hope this helps. signature MIRTYPES = sig end; signature MIRPRINT = sig structure MirTypes : MIRTYPES end; functor Mir_Utils( structure MirTypes : MIRTYPES structure MirPrint : MIRPRINT sharing MirTypes = MirPrint.MirTypes ) = struct end; structure MirTypes_ = struct end; structure Mir_Utils_ = Mir_Utils( structure MirTypes = MirTypes_ ); Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 515 Title: Compiler bug: patType -- unexpected pattern Keywords: Submitter: jont@uk.co.harlqn Date: 24/01/92 Version: SML of NJ version 0.75 System: Sun 4/330 with Sunos 4.1.1 Severity: minor Problem: Compiler bug Code: | has_a_new_name (TYFUN (CONSTYPE (_,METATYNAME{ref tyfun, ...}),_)) = Transcript: /usr/users/jont/ml/ml_compiler/src/typechecker/_types.sml:383.57-383.61 Error: syntax error: inserting AS /usr/users/jont/ml/ml_compiler/src/typechecker/_types.sml:1177.38 Error: syntax error: inserting ASTERISK Error: Compiler bug: patType -- unexpected pattern [closing /usr/users/jont/ml/ml_compiler/src/typechecker/_types.sml] Comments: same as #474? Status: fixed in 0.83 (probably) ---------------------------------------------------------------------- Number: 516 Title: ml-lex gives uncaught exception LOOKUP (same as 475, 510) Keywords: Submitter: John Reppy Date: 2/4/92 Version: ? Severity: significant Problem: One of my students was getting the following mysterious error message from mllex: ? sml-lex: uncaught exception LOOKUP upon examination, the problem is that he misspelled a character class name. The following small file will produce this behavior: Code: cat foo.lex (* test file *) %% foo = [a-z]; %% {foob}+ => (lex()); Status: same as 475 ---------------------------------------------------------------------- Number: 517 Title: type errors in examples/cat.sml Keywords: Submitter: Doug McIlroy Date: 2/4/92 Version: ? Severity: minor Problem: doc/examples/cat.sml contains type errors Status: fixed in 0.90 (in /usr/local/sml/75/doc/examples/cat.sml) ---------------------------------------------------------------------- Number: 518 Title: interrupt causes core dump (same as 484, 511) Keywords: Submitter: jont@uk.co.harlqn Date: 12/02/92 Version: SML of NJ version number 0.75 System: Sun 4/330 with SunOS 4.1.1 Severity: minor Problem: Unreliability of NJ 0.75 with ^c Transcript: SIGEMT not related to gc (bogus test: 0x9de3bfc0 @ 0xa150) Comments: This seems to happen a lot when using ctrl-c to halt a looping or long running program. Even if this doesn't happen, the image sometimes seems corrupt afterwards, in that it exhibits strange (impossible) behaviour that doesn't occur if it is recompiled from scratch to supposedly the same state. I suspect there is a critcial region problem somewhere. Status: obsolete ---------------------------------------------------------------------- Number: 519 Title: System.system broken after loading sml-yacc output Keywords: Submitter: John Nestoriak Date: 2/16/92 Version: 0.75 Severity: major Problem: I'm having a problem using system calls from sml 75. Something like System.system "ls"; works fine until I load the output from sml-yacc. Then I get uncaught exception SystemCall. [from cazin@tls-cs.cert.fr (Jacques Cazin), 3/26/92] But we use also lexgen and mlyacc which are in the distribution. After having loaded lexgen, we cannot use "System.system" anymore: System.system "pwd"; (or anything else) gives rise to uncaught exception SystemCall We previously used version 0.56 with lexgen as well and did not observe this behaviour. Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 520 Title: broken under IRIX 4.0.1 Keywords: Submitter: Lindsay Errington Date: 2/17/92 Version: 0.75 System: SGI/IRIX 4.0.1 Severity: major Problem: I'm sorry to bother you with such a vague problem but I'm having a little trouble with your compiler under IRIX. We've just upgraded from Irix 3.3.x to version 4.0.1 and since then any attempt to use the "use" function made SML 0.75 hang. I tried to re-compile the runtime but then it only gets as far as [Executing IEEEReal] before it hangs again. I've done a little diddling and as far as I can tell it's hung in prim.s. Any suggestions on where to start looking or whom to contact? Status: fixed in 0.81 ---------------------------------------------------------------------- Number: 521 Title: type checking flex records Keywords: Submitter: Mark Leone (mleone@cs.cmu.edu) Date: 2/12/92 Version: 0.75 System: Decstation 2100 under Mach 2.6 Severity: major Problem: Type checker doesn't handle flex records correctly. Code: fun foo x = let val a = #1 x val (a,b) = x in b () end Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - fun foo x = let val a = #1 x val (a,b) = x in b () end ; = = = = = val foo = fn : 'a * 'b -> 'c - foo (0,0); Process sml segmentation fault Comments: Type of foo should be ('a * (unit -> 'b)) -> 'b Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 522 Title: redundent patterms in compiler Keywords: Submitter: John Reppy Date: 2/18/92 Version: 0.76? Severity: minor Transcript: build/index.sml:177.4 Warning: redundant patterns in match VALdec vbs => ... VALRECdec rvbs => ... TYPEdec tbs => ... DATATYPEdec {datatycs=datatycs,withtycs=withtycs} => ... ABSTYPEdec {abstycs=abstycs,body=body,withtycs=withtycs} => ... EXCEPTIONdec ebs => ... STRdec sbs => ... ABSdec sbs => ... FCTdec fbs => ... SIGdec sigvars => ... LOCALdec (inner,outer) => ... SEQdec decs => ... OPENdec strVars => ... MARKdec (dec,L1,L2) => ... FIXdec _ => ... OVLDdec _ => ... IMPORTdec _ => ... --> _ => ... translate/translate.sml:259.30 Warning: redundant patterns in match VALtrans (PATH p) => ... VALtrans (INLINE POLYEQL) => ... VALtrans (INLINE POLYNEQ) => ... VALtrans (INLINE INLSUBSCRIPT) => ... VALtrans (INLINE INLUPDATE) => ... VALtrans (INLINE INLBYTEOF) => ... VALtrans (INLINE INLSTORE) => ... VALtrans (INLINE INLORDOF) => ... VALtrans (INLINE INLFSUBSCRIPTd) => ... VALtrans (INLINE INLFUPDATEd) => ... VALtrans (INLINE i) => ... THINtrans (PATH p,v,locs) => ... CONtrans (d as DATACON {const=true,...}) => ... CONtrans (d as DATACON {const=false,...}) => ... VALtrans a => ... THINtrans (a,_,_) => ... --> _ => ... cps/cpsopt.sml:1129.4 Warning: redundant patterns in match RECORD (vl,w,e) => ... SELECT (i,v,w,e) => ... OFFSET (i,v,w,e) => ... APP (f,vl) => ... FIX (l,e) => ... SWITCH (v,_,el) => ... BRANCH (_,vl,c,e1,e2) => ... LOOKER (_,vl,w,e) => ... SETTER (_,vl,e) => ... PURE (_,vl,w,e) => ... ARITH (args as (floor,_,_,_)) => ... ARITH (args as (round,_,_,_)) => ... ARITH (args as (fadd,_,_,_)) => ... ARITH (args as (fdiv,_,_,_)) => ... ARITH (args as (fmul,_,_,_)) => ... ARITH (args as (fsub,_,_,_)) => ... ARITH (_,vl,w,e) => ... --> PURE (args as (fnegd,v :: nil,w,e)) => ... --> PURE (real,vl,w,e) => ... Status: fixed in 0.81 ---------------------------------------------------------------------- Number: 523 Title: printing uncaught exceptions Keywords: Submitter: Richard O'Neill Date: 2/27/92 Version: 0.75 System: NeXTstation, OS2.1 Severity: Major annoyance Problem: If a value happens to be of type exn, the top level loop won't print out the value, but instead says 'val it = exn : exn'; this is not acceptable behaviour in my opinion. When debugging, I like to be able to pass back information when an fatal exception is raised. It is bad enough that if you have: exception InvalidKey of int; ... raise InvalidKey 6502; it gives the message uncaught exception InvalidKey and not: uncaught exception: InvalidKey 6502 (But the 'Io' exception does 'do the right thing'- special case treatment or what :o) But I can put up with that - what really annoys me is that even the top level won't print exception values, i.e. - val theException = InvalidKey 6502; val theException = exn : exn In order to find the value, I need to do: - case theException of InvalidKey key => key; std_in:3.1-3.42 Warning: match not exhaustive InvalidKey key => ... val it = 6502 : int This is annoying, because it means more work for me to do, especially if the datastructure is a *chain* of exception values (e.g. something like 'exception ReraiseBacktrace of functionName * parameters * exn' - you get the idea anyway). In such a case, I have to follow the chain *by hand*. I realise that printing exeptions may be harder than printing ordinary constructors, but don't think this is a good reason not to print them. [Richard O'Neill, 11/24/92] Standard ML of New Jersey, Version 0.92, November 18, 1992 val it = () : unit - val some_exceptions = [Interrupt, Match, Bind, Io "Foobar"]; val some_exceptions = [exn,exn,exn,exn] : exn list - ^D If a value happens to be of the exception type, it is always printed in a most uninformative way. Obviously, I'd like to see: Standard ML of New Jersey, Version 0.93, February 17, 1993 ;-) val it = () : unit - val some_exceptions = [Interrupt, Match, Bind, Io "Foobar"]; val some_exceptions = [Interrupt, Match, Bind, Io "Foobar"] : exn list - ^D Thus bug already has a number, 523, but the title "printing uncaught exceptions" is misleading, and I expect probably the reason it hasn't been fixed (yet). (Better printing of uncaught exceptions would be nice too, but that is far less important to me). Unless I'm seriously mistaken, this bug would only take minutes to fix, for someone who knows SML-NJ's data-structures. Comment: (awa) Fixed a little bit; exn values now print a top level, but not the value carried by the constructor. Status: not a bug (entirely) ---------------------------------------------------------------------- Number: 524 Title: weak polymorphism Keywords: Submitter: shail@au-bon-pain.lcs.mit.edu (Shail Aditya) Date: 12/19/91 Version: ? Severity: major Problem: I ran across this quirk in the ranked weak type inference in SML-NJ. I am running the version 0.75 on Sparc (sunos). - val g3 = (fn f => (fn x => f x)); val g3 = fn : ('a -> 'b) -> 'a -> 'b - g3 ref; std_in:5.1-5.6 Error: nongeneric weak type variable it : '0Z -> '0Z ref - The "ref" does not happen until another argument is supplied to "g3 ref", so proper ranking analysis should have made its type to be "'1a -> '1a ref" without any error. - val g = (fn x => x); val g = fn : 'a -> 'a - g ref; std_in:3.1-3.5 Error: nongeneric weak type variable it : '0Z -> '0Z ref But the following works. - val h = (fn x => let val g = fn x => x in g ref end); val h = fn : 'a -> '1b -> '1b ref - val h = (fn x => let val g = (fn f => (fn x => f x)) in g ref end); val h = fn : 'a -> '1b -> '1b ref - Basically, it seems that "ref" is opened up to the enclosing lambda rank unnecessarily when it is passed as an argument. This system works fine in first order situations but fails in higher order argument passing when the arguments are weakly polymorphic functions. Am I to understand that the ranked system of SML-NJ is not powerful enough to keep track of weak polymorphism across higher order function applications? Or is this merely a bug? I would like to obtain a clearer description of the ranked system you follow. Preferably in terms of a paper that gives the inference rules. I have a system that behaves similarly, only that it allows toplevel non-ground weak types as well. I would like to know the SML-NJ solution better. Do you have any pointers? Status: not a bug (a "feature" of weak polymorphism) ---------------------------------------------------------------------- Number: 525 Title: IO.execute broken Keywords: Submitter: Mikael Pettersson, mpe@ida.liu.se Date: 1/7/92 Version: 0.75 System: SPARCstation ELC, SunOS 4.1.1 Severity: major Problem: the input stream from IO.execute is unusable: can_input and close_in fail with exceptions, input causes a segmentation violation Transcript: ==== - val (is,_) = execute("/bin/echo",["foo"]); val is = - : instream - close_in is; uncaught exception Io "close_in "": close failed, Bad file number" ==== - val (is,_) = execute("/bin/echo",["foo"]); val is = - : instream - input(is,1); Segmentation fault (core dumped) ==== - val (is,_) = execute("/bin/echo",["foo"]); val is = - : instream - can_input is; uncaught exception SystemCall - (can_input is) handle (System.Unsafe.CInterface.SystemCall s) => (print s; print "\n"; 999); fionread failed, Bad file number val it = 999 : int Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 526 Title: Harlequin gripes Keywords: Submitter: Andrew Tolmach Date: 3/2/92 Version: 0.75 Severity: minor Problem: 1) If one uses polymorphic equality on, say, integer types, the equality test is much slower than using a type-specific equality operator. This was probably in the context of functors, in which case its no big surprise, but might bear looking into further. 2) They were unhappy with the time cost of referencing elements out of structures at runtime. They often do something like inserting an explicit declaration val thing = A.thing same thing for them automatically. They also suggested that we don't tend to notice this problem because we use "open" all over the place, a practice they abominate. Status: not a bug ---------------------------------------------------------------------- Number: 527 Title: uncaught exception Subscript while printing value of a datatype Keywords: Submitter: John Reppy Date: 3/9/92 Version: 0.78 Severity: major Problem: compiling following code causes uncaught exception Subscript Code: (* string-util.sml * * Various string utilities. *) structure StringUtil = struct datatype relation_t = Equal | LessTh | GreaterTh (* lexically compare two strings and return their relation *) fun strcmp (s1, s2) = (case (size s1, size s2) of (0, 0) => Equal | (0, _) => LessTh | (_, 0) => GreaterTh | (n1, n2) => let fun loop i = let val c1 = ordof(s1, i) and c2 = ordof(s2, i) in if (c1 = c2) then loop(i+1) else if (c1 < c2) then LessTh else GreaterTh end in (loop 0) handle _ => ( if (n1 = n2) then Equal else if (n1 < n2) then LessTh else GreaterTh) end (* strcmp *) (* end case *)) (* Lexically sort a list of values with unique string keys. The function * proj extracts the key of an item. Raise Repeat if two items have the * same key. *) exception Repeat of string fun sortStrings proj = let fun le (f1, f2) = (case strcmp(proj f1, proj f2) of LessTh => true | GreaterTh => false | Equal => raise Repeat(proj f1) (* end case *)) fun insert (f, []) = [f] | insert (f, l as (f'::r)) = if le(f, f') then f::l else f'::insert(f, r) fun sort ([], l) = l | sort (f::r, l) = sort(r, insert(f, l)) in fn l => sort (l, []) end end (* StringUtil *) (* this is a SML implementation of Luca's Amber code *) (* Types are represented by values in the following type. Rec bound variables * in a recursive type are represented by the RecTy node in which they are bound. * For example, the representation of the following Amber type * * rec (t) [nil : Unit, cons : {hd : Int, tl : t}] * * is constructed by the following ML code: * * let * val recBody = ref Any * val recTy = RecTy{bind = "t", typ = recBody} * val body = VariantTy[ * FieldTy{tag = "nil", typ = BaseTy UnitTy}, * FieldTy{tag = "cons", typ = RecordTy[ * FieldTy{tag = "hd", typ = BaseTy IntTy}, * FieldTy{tag = "tl", typ = recTy}, * ] * ] * in * recBody := body; * recTy * end *) datatype base_ty = UnitTy | BoolTy | IntTy | StringTy | DynamicTy datatype typ = AnyTy (* | ExistTy of {name : string, instance : typ option, suptypes : typ list}*) | BaseTy of base_ty | FunTy of (typ * typ) | TupleTy of typ list | RecordTy of field_ty list (* assume fields are sorted by tag *) | VariantTy of field_ty list | RecTy of {bind : string, typ : typ ref} | ArrayTy of typ | ChannelTy of typ and field_ty = FieldTy of {tag : string, typ : typ} fun seen (stk, ty1 : typ, ty2 : typ) = let val x = (ty1, ty2) fun look [] = false | look (y::r) = (x = y) orelse look r in look stk end (* return true if the types are "equal" *) fun sameType (ty1, ty2) = let fun sameTy (AnyTy, _, _) = true | sameTy (_, AnyTy, _) = true | sameTy (BaseTy b1, BaseTy b2, _) = (b1 = b2) | sameTy (FunTy(t1, s1), FunTy(t2, s2), stk) = sameTy(t1, t2, stk) andalso sameTy(s1, s2, stk) | sameTy (TupleTy tl1, TupleTy tl2, stk) = let fun sameTyList ([], []) = true | sameTyList (ty1::r1, ty2::r2) = sameTy(ty1, ty2, stk) andalso sameTyList(r1, r2) in sameTyList(tl1, tl2) end | sameTy (RecordTy fl1, RecordTy fl2, stk) = sameFieldList (fl1, fl2, stk) | sameTy (VariantTy fl1, VariantTy fl2, stk) = sameFieldList (fl1, fl2, stk) | sameTy (ty1 as RecTy{typ=ty1', ...}, ty2 as RecTy{typ=ty2', ...}, stk) = (ty1' = ty2') orelse seen(stk, ty1, ty2) orelse sameTy(!ty1', !ty2', (ty1, ty2)::stk) | sameTy (ty1 as RecTy{typ, ...}, ty2, stk) = seen(stk, ty1, ty2) orelse sameTy(!typ, ty2, (ty1, ty2)::stk) | sameTy (ty1, ty2 as RecTy{typ, ...}, stk) = seen(stk, ty1, ty2) orelse sameTy(ty1, !typ, (ty1, ty2)::stk) | sameTy (ArrayTy ty1, ArrayTy ty2, stk) = sameTy(ty1, ty2, stk) | sameTy (ChannelTy ty1, ChannelTy ty2, stk) = sameTy(ty1, ty2, stk) | sameTy _ = false and sameFieldList ([], [], _) = true | sameFieldList (FieldTy{tag=a, typ=t}::r1, FieldTy{tag=b, typ=s}::r2, stk) = (a = b) andalso sameTy(t, s, stk) andalso sameFieldList(r1, r2, stk) | sameFieldList _ = false in sameTy (ty1, ty2, []) end (* return true, if ty1 is a subtype of ty2 *) fun isSubtyOf (ty1, ty2) = let exception TypeError (* given two sorted lists of field types, where the second should contain all of * tags of the first list, return the projection of those fields from the second * list. *) fun projFieldList (fl1, fl2) = let fun proj ([], _, l) = rev l | proj (_, [], _) = raise TypeError | proj ( l1 as (FieldTy{tag=a, ...}::r1), l2 as ((f as FieldTy{tag=b, ...})::r2), l ) = ( print(implode["proj: a = ", a, ", b = ", b, "\n"]); case (StringUtil.strcmp(a, b)) of StringUtil.Equal => proj (r1, r2, f::l) | StringUtil.GreaterTh => proj (l1, r2, l) | StringUtil.LessTh => proj (r1, l2, l) (* end case *)) in proj (fl1, fl2, []) end fun subTy (AnyTy, _, _) = true | subTy (_, AnyTy, _) = true | subTy (BaseTy b1, BaseTy b2, _) = (b1 = b2) | subTy (ty1 as RecTy{typ=ty1', ...}, ty2 as RecTy{typ=ty2', ...}, stk) = (ty1' = ty2') orelse seen(stk, ty1, ty2) orelse subTy(!ty1', !ty2', (ty1, ty2)::stk) | subTy (ty1 as RecTy{bind, typ}, ty2, stk) = seen(stk, ty1, ty2) orelse subTy(!typ, ty2, (ty1, ty2)::stk) | subTy (ty1, ty2 as RecTy{bind, typ}, stk) = seen(stk, ty1, ty2) orelse subTy(ty1, !typ, (ty1, ty2)::stk) | subTy (FunTy(ty1, ty2), FunTy(ty1', ty2'), stk) = subTy(ty1', ty1, stk) andalso subTy(ty2, ty2', stk) | subTy (TupleTy tl1, TupleTy tl2, stk) = let fun subTyList ([], []) = true | subTyList (t1::r1, t2::r2) = subTy(t1, t2, stk) andalso subTyList(r1, r2) | subTyList _ = false in subTyList(tl1, tl2) end | subTy (RecordTy f1, RecordTy f2, stk) = let val f1' = projFieldList (f2, f1) in subFieldList (f1', f2, stk) end | subTy (VariantTy f1, VariantTy f2, stk) = let val f2' = projFieldList (f1, f2) in subFieldList (f1, f2', stk) end | subTy (ArrayTy ty1, ArrayTy ty2, _) = sameType(ty1, ty2) | subTy (ChannelTy ty1, ChannelTy ty2, _) = sameType(ty1, ty2) | subTy _ = false (* this should only be called on field lists that have the same tags *) and subFieldList ([], [], _) = true | subFieldList (FieldTy{typ=t, ...}::r1, FieldTy{typ=s, ...}::r2, stk) = subTy(t, s, stk) andalso subFieldList(r1, r2, stk) in (subTy (ty1, ty2, [])) handle TypeError => false end fun revApp ([], l) = l | revApp (x::r, l) = revApp(r, x::l) (* Return the union of two field lists, with f mapped over their intersection. *) fun unionFieldMap f = let fun union ([], [], l) = revApp (l, []) | union ([], l2, l) = revApp (l, l2) | union (l1, [], l) = revApp (l, l1) | union ( l1 as ((f1 as FieldTy{tag=a, typ=t1})::r1), l2 as ((f2 as FieldTy{tag=b, typ=t2})::r2), l ) = (case (StringUtil.strcmp(a, b)) of StringUtil.Equal => union (r1, r2, FieldTy{tag = a, typ = f(t1, t2)}::l) | StringUtil.GreaterTh => union (l1, r2, f2::l) | StringUtil.LessTh => union (r1, l2, f1::l) (* end case *)) in fn (fl1, fl2) => union (fl1, fl2, []) end (* Map f over the intersection of two field lists *) fun interFieldMap f = let fun inter ([], _, l) = revApp (l, []) | inter (_, [], l) = revApp (l, []) | inter ( l1 as (FieldTy{tag=a, typ=t1}::r1), l2 as (FieldTy{tag=b, typ=t2}::r2), l ) = (case (StringUtil.strcmp(a, b)) of StringUtil.Equal => inter (r1, r2, FieldTy{tag = a, typ = f(t1, t2)}::l) | StringUtil.GreaterTh => inter (r1, l2, l) | StringUtil.LessTh => inter (l1, r2, l) (* end case *)) in fn (fl1, fl2) => inter (fl1, fl2, []) end exception Join fun joinTy (AnyTy, _) = AnyTy | joinTy (_, AnyTy) = AnyTy | joinTy (ty as BaseTy b1, BaseTy b2) = if (b1 = b2) then ty else raise Join | joinTy (TupleTy tl1, TupleTy tl2) = let fun joinTyList ([], []) = [] | joinTyList ([], _) = raise Join | joinTyList (_, []) = raise Join | joinTyList (ty1::r1, ty2::r2) = joinTy(ty1, ty2) :: joinTyList(r1, r2) in TupleTy(joinTyList (tl1, tl2)) end | joinTy (FunTy(ty1, ty2), FunTy(ty1', ty2')) = FunTy(meetTy (ty1, ty1'), joinTy (ty2, ty2')) | joinTy (RecordTy fl1, RecordTy fl2) = RecordTy (interFieldMap joinTy (fl1, fl2)) | joinTy (VariantTy fl1, VariantTy fl2) = VariantTy (unionFieldMap joinTy (fl1, fl2)) and meetTy (AnyTy, _) = AnyTy | meetTy (_, AnyTy) = AnyTy | meetTy (ty as BaseTy b1, BaseTy b2) = if (b1 = b2) then ty else raise Join | meetTy (TupleTy tl1, TupleTy tl2) = let fun meetTyList ([], []) = [] | meetTyList ([], _) = raise Join | meetTyList (_, []) = raise Join | meetTyList (ty1::r1, ty2::r2) = meetTy(ty1, ty2) :: meetTyList(r1, r2) in TupleTy(meetTyList (tl1, tl2)) end | meetTy (FunTy(ty1, ty2), FunTy(ty1', ty2')) = FunTy(joinTy (ty1, ty1'), meetTy (ty2, ty2')) | meetTy (RecordTy fl1, RecordTy fl2) = RecordTy (unionFieldMap meetTy (fl1, fl2)) | meetTy (VariantTy fl1, VariantTy fl2) = VariantTy (interFieldMap meetTy (fl1, fl2)) (**** Test code ***) fun mkRecTy (id, mkTy) = let val recBody = ref AnyTy val recTy = RecTy{bind = id, typ = recBody} in recBody := mkTy(recTy); recTy end fun mkVar1 (tag, ty) = VariantTy[FieldTy{tag = tag, typ = ty}] val unitTy = BaseTy UnitTy val intTy = BaseTy IntTy (* rec (t) [nil : Unit, cons : {hd : Int, tl : t}] *) val intListTy = mkRecTy("t", fn recTy => VariantTy[ FieldTy{tag = "nil", typ = unitTy}, FieldTy{tag = "cons", typ = RecordTy[ FieldTy{tag = "hd", typ = intTy}, FieldTy{tag = "tl", typ = recTy} ]} ]) (* [cons : {hd : Int, tl : [nil : Unit]}] *) val intListTy' = VariantTy[ FieldTy{tag = "cons", typ = RecordTy[ FieldTy{tag = "hd", typ = intTy}, FieldTy{tag = "tl", typ = VariantTy[ FieldTy{tag = "nil", typ = unitTy} ]} ]} ] ==== The following shorter example causes an uncaught subscript in 0.77 & 0.78 (but not in 0.77b): datatype tree = Leaf of int | Plus of (tree * tree * int); (Plus (Leaf 0,Leaf 1,2),2); for example: Standard ML of New Jersey, Version 0.78, February 26, 1992 Arrays have changed; see Release Notes val it = () : unit - datatype tree = Leaf of int | Plus of (tree * tree * int); datatype tree con Leaf : int -> tree con Plus : tree * tree * int -> tree - (Plus (Leaf 0,Leaf 1,2),2); val it = (Plus ( uncaught exception Subscript - Comment: Bug appeared between 0.77b and 0.77. Possibly related to change in dataconstructor representations. >Submitter: Andrzej Filinski >Date: March 19, 1992 >Version: 0.78 >System: All >Severity: Major >Problem: Printing certain datatype values raises Subscript >Transcript: Standard ML of New Jersey, Version 0.78, February 26, 1992 Arrays have changed; see Release Notes val it = () : unit - datatype foo = BAR of int | BAZ of foo * foo; datatype foo con BAR : int -> foo con BAZ : foo * foo -> foo - BAZ (BAR 1, BAR 2); val it = BAZ ( uncaught exception Subscript - [Bob Harper, 4/10/92]: Dave Tarditi suggested that the constructor printing problem might be due to the fact that something or other got reversed in the code generator, but this was forgotten in the print routines. Apparently some representation is now done in reverse order. I consistently get the following behavior: 1. Build a system using SourceGroup.make. 2. Open a particular structure, making available a constructor Abs (among many others). 3. Modify things, do another make. 4. Uses of Abs suddenly get weird type errors. Typing Abs at top level results in "val it = exn : exn". I could send the whole system, but this seems excessive.... Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 528 Title: Compiler bug: ModuleUtil.teststr 2 Keywords: Submitter: Ian Green, aisb@ed.ac.uk Date: 3/18/92 Version: 0.75 System: Sun SPARC 1+, SunOS 4.1 Severity: john major Problem: Error: Compiler bug: ModuleUtil.teststr 2 Code: ************ UnifyFUN.sml ************* import "TermsSIG"; import "UnifySIG"; functor Unifier(structure Terms:TERMS):UNIFY = struct local open Terms fun unifyst _ _ _ = [] in fun mgu t1 t2 = unifyst [] [(t1,t2)] [] handle No_Unifier => [] end end **************************************** ************ UnifySIG.sml ************** import "TermsSIG"; signature UNIFY = sig local structure Terms:TERMS open Terms in val mgu : Terms.term -> Terms.term -> (Terms.atom * Terms.term) list end end ***************************************** ********** TermsSIG.sml *************** signature TERMS = sig datatype atom = Var of string | Const of string datatype term = Atomic of atom | Term of atom * term list | WhereTerm of atom list * term * term; val subst : atom list -> (atom * term) list -> term -> term end; **************************************** ************ TermsFUN.sml ************* import "TermsSIG"; functor Terms( ):TERMS = struct datatype atom = Var of string | Const of string datatype term = Atomic of atom | Term of atom * term list | WhereTerm of atom list * term * term; fun subst _ _ t = t (* i like this case *) end; **************************************** ************ load ****************** import "TermsFUN"; import "UnifyFUN"; structure Term = Terms( ); structure Unify = Unifier(structure Terms = Term); **************************************** Transcript: In summary, I do three `use "load"' starting with no bin files. The first gives no error, but i get types (what does that mean). Second time a recompile is needed (odd?) and get a Compiler bug: On the third try, no recompile needed, but get same compiler bug report. Here it is in all its (gory) detail. --------------------------------------------------------- Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "load"; [opening load] [reading TermsFUN.sml] [reading TermsSIG.sml] [writing TermsSIG.bin... done] [closing TermsSIG.sml] [writing TermsFUN.bin... done] [closing TermsFUN.sml] functor Terms signature TERMS [reading UnifyFUN.sml] [reading TermsSIG.bin... done] [reading UnifySIG.sml] [reading TermsSIG.bin... done] UnifySIG.sml:6.6-8.1 Warning: LOCAL specs are only partially implemented [writing UnifySIG.bin... done] [closing UnifySIG.sml] [writing UnifyFUN.bin... done] [closing UnifyFUN.sml] functor Unifier signature UNIFY signature TERMS structure Term : sig datatype atom con Const : string -> atom con Var : string -> atom datatype term con Atomic : atom -> term con Term : atom * term list -> term con WhereTerm : atom list * term * term -> term val subst : atom list -> (atom * term) list -> term -> term end structure Unify : UNIFY [closing load] val it = () : unit - Unify.mgu; val it = fn : -> -> ( * ) list - use "load"; [opening load] [reading TermsFUN.bin... ] [import(s) of TermsFUN are out of date; recompiling] [closing TermsFUN.bin] [reading TermsFUN.sml] [reading TermsSIG.bin... done] [writing TermsFUN.bin... done] [closing TermsFUN.sml] functor Terms signature TERMS [reading UnifyFUN.bin... done] functor Unifier signature UNIFY signature TERMS structure Term : sig datatype atom con Const : string -> atom con Var : string -> atom datatype term con Atomic : atom -> term con Term : atom * term list -> term con WhereTerm : atom list * term * term -> term val subst : atom list -> (atom * term) list -> term -> term end Error: Compiler bug: ModuleUtil.teststr 2 [closing load] - use "load"; [opening load] [reading TermsFUN.bin... done] functor Terms signature TERMS [reading UnifyFUN.bin... done] functor Unifier signature UNIFY signature TERMS structure Term : sig datatype atom con Const : string -> atom con Var : string -> atom datatype term con Atomic : atom -> term con Term : atom * term list -> term con WhereTerm : atom list * term * term -> term val subst : atom list -> (atom * term) list -> term -> term end Error: Compiler bug: ModuleUtil.teststr 2 [closing load] - Comments: I see from the compiler that LOCAL specs are only partially implemented, so this is probably the cause, though i dont get the bit. As I am new to modules in ML, its all probably meaningless code anyway, but I thought I ought to drop you a line. Status: not a bug --- cannot reproduce (bug report incomplete); probably fixed. ---------------------------------------------------------------------- Number: 529 Title: memory leak Keywords: Submitter: schristensen@daimi.aau.dk (Soren Christensen) Date: 3/20/92 Version: 0.75 Severity: major Problem: I have a problem that my system slows down after running a short while. Instead of using the ordinary top-loop of the compiler I run my own. This means that I evaluate ML code in the following way: use_stream (open_string "code"); It seems that this construct creates 16 bytes of "garbage" which is never collected. My first idea was that I needed to close the stream which is created, i.e., let val is = open_string "code" in use_stream is; close_in is end; But this does not fix the problem. It seems that "close_in is" have no effect. At least it reports no errors when a use_string is performed on a stream which has been closed. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 530 Title: missing space in printing abstype declaration Keywords: Submitter: Mikael Pettersson, mpe@ida.liu.se Date: 3/20/92 Version: 0.75 System: all Severity: minor Problem: when printing a polymorphic abstype, no space is inserted between the "type" symbol and the type variable Transcript: - abstype 'a foo = FOO of 'a list = with = fun mkfoo() = FOO [] = end; type'a foo (* note: missing space after "type" *) val mkfoo = fn : unit -> 'a foo Fix: --cut here-- *** src/print/printdec.sml.~1~ Fri Oct 18 23:21:13 1991 --- src/print/printdec.sml Fri Mar 20 14:00:07 1992 *************** *** 50,56 **** printSym name; print " = "; printType env def; newline()) and printAbsTyc(GENtyc{path=name::_, arity, eq, kind=ref(ABStyc _), ...}) = ! (print(if (!eq=YES) then "eqtype" else "type"); printFormals arity; print " "; printSym name; newline()) --- 50,56 ---- printSym name; print " = "; printType env def; newline()) and printAbsTyc(GENtyc{path=name::_, arity, eq, kind=ref(ABStyc _), ...}) = ! (print(if (!eq=YES) then "eqtype " else "type "); printFormals arity; print " "; printSym name; newline()) --cut here-- Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 531 Title: Compiler bug: CoreLang.makeOVERLOADdec.option Keywords: Submitter: John Reppy Date: 3/24/92 Version: 0.78 Severity: major Problem: I noticed a "CoreLang.makeOVERLOADdec.option" compiler bug (this also occurs in 0.78): Transcript: cat boot/perv.sml structure Foo = struct val x = InLine.:= end smlc Standard ML of New Jersey, Version 0.78, February 26, 1992 (batch compiler) ~mBoot [mBoot()] ... [Compiling boot/perv.sml] structure Foo : ... [closing boot/perv.sml] boot/overloads.sml:4.15-4.21 Error: unbound structure Initial boot/overloads.sml:6.7-6.21 Error: unbound structure Bool in path Bool.makestring boot/overloads.sml:6.27-6.44 Error: unbound structure Integer in path Integer.makestring boot/overloads.sml:6.50-6.64 Error: unbound structure Real in path Real.makestring Error: Compiler bug: CoreLang.makeOVERLOADdec.option [closing boot/overloads.sml] [Failed on "~mBoot" with Syntax] Comment: [dbm] This should never be visible to a user. Status: not a bug ---------------------------------------------------------------------- Number: 532 Title: squaring big real number dumps core on sparc (see also 638) Keywords: Submitter: rst@ai.mit.edu (Robert S. Thau) Date: 3/24/92 Version: ? System: Sparc Severity: Problem: To repeat this, just attempt to square 1.0E~160 on your nearest sparcstation in SML/NJ. The process will die, complaining that "underflow should not trap". Fix: As I read the source code, the machine-independant signal-handling code (in signal.c) expects floating point underflows not to trap, but the machine- dependant code does enable underflow trapping. Accordingly, here's a one-line fix to SPARC.dep.c in the runtime directory: *** SPARC.dep.c Tue Mar 24 18:08:57 1992 --- SPARC.dep.c.~1~ Tue Aug 20 12:03:52 1991 *************** *** 108,112 **** SETSIG (SIGILL, fpe_handler, mask); #endif MACH ! set_fsr (0x0d000000); /* enable FP exceptions NV, OF & DZ; disable UF */ } --- 108,112 ---- SETSIG (SIGILL, fpe_handler, mask); #endif MACH ! set_fsr (0x0f000000); /* enable FP exceptions NV, OF, UF & DZ */ } Status: fixed in 0.90 ---------------------------------------------------------------------- Number: 533 Title: typing record types Keywords: Submitter: Richard O'Neill Date: 3/24/92 Version: 0.75 (and 0.73, don't know about 0.78) System: NeXTstation, OS2.1 & Sun4 SunOS 4.1.1. Severity: Major Problem: The type system is *broken* w.r.t. record types. The problem is tied in with use of flex records (but I do NOT mean the 'unresolved flex record in let pattern' business that novice programmers sometimes fail to understand). The type checker gives an incorrect (too general) typing for valid SML. A very minor change causes a correct typing to be given. The best way to show this bug is to give some code that reproduces it: (* * The compiler incorrectly types this function as: * {key:''a,value:'b} list -> {key:''a,value:'c} -> {key:''a,value:'b} list * ^--- should be 'b *) fun insert1 alist (item as {key=desired, ...}) = let (* ^--- remember this bit *) fun worker nil = item :: nil | worker ({key,value} :: items) = if key = desired then item :: items else worker items in (worker alist) end (* * The compiler correctly types this function as: * {key:''a,value:'b} list -> {key:''a,value:'b} -> {key:''a,value:'b} list * ^--- correct *) fun insert2 alist (item as {key=desired, value = _}) = let (* ^--- the only difference *) fun worker nil = item :: nil | worker ({key,value} :: items) = if key = desired then item :: items else worker items in (worker alist) end Transcript: unix% sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "typing-bug.sml" (* Just the source as shown above... *); [opening typing-bug.sml] val insert1 = fn : {key:''a,value:'b} list -> {key:''a,value:'c} -> {key:''a,value:'b} list val insert2 = fn : {key:''a,value:'b} list -> {key:''a,value:'b} -> {key:''a,value:'b} list [closing typing-bug.sml] val it = () : unit - val [{value=foo, ...}] = insert1 nil {key=17, value=100} (* broken *) = and [{value=bar, ...}] = insert2 nil {key=17, value=100} (* okay *) ; std_in:3.1-4.56 Warning: binding not exhaustive {value=bar,...} :: nil = ... std_in:3.1-4.56 Warning: binding not exhaustive {value=foo,...} :: nil = ... val foo = - : 'a val bar = 100 : int - foo : int; val it = 100 : int - foo : string; val it = "d" : string - foo : real; (* This one's cruel, I know... *) Bus error (core dumped) unix% Comment: In practice, it isn't to much of a problem as one can always restrict the type or use the form that types correctly. Even so, it does reflect a problem in the type checker and ought to be fixed. Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 534 Title: .bin files for share and noshare compiler incompatible Keywords: Submitter: Bernard Sufrin Date: 3/24/92 Version: 0.75 System: Sparc/SUNOS 4.1.1 Severity: minor Problem: I have a good deal of evidence that .bin files compiled by the shared compiler and those compiled by the unshared compiler are incompatible. Shared compiler generated .bin files cause the unshared compiler to crash with a bus error, and vice versa. Status: fixed in 0.95 ---------------------------------------------------------------------- Number: 535 Title: Problems with non-equality types (bug or language problem?) (see also 341) Keywords: Submitter: Richard O'Neill Date: 3/25/92 Version: 0.75 (and 0.73, don't know about 0.78) System: NeXTstation, OS2.1 & Sun4 SunOS 4.1.1. Severity: Major Problem: I'm not sure if this is a bug or a language 'feature' - whatever it is, it is certainly unnecessarily restrictive and needs fixing... If I have a reference to a type that does not admit equality, I can still test *references* to that type for equality. But, if that reference is wrapped up as part of a structured type, I cannot. It isn't necessarily tied to references. It also applies to any parametric types which don't actually contain an element of the type, such as: datatype 'a type_only = TypeOnly Take a look at the transcript below... Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - abstype abstract = Abstract with val abstract = Abstract end; type abstract val abstract = - : abstract - val abstract_ref = ref abstract; val abstract_ref = ref - : abstract ref - abstract_ref = abstract_ref; val it = true : bool - - datatype 'a wrapped_ref = WrappedRef of 'a ref; datatype 'a wrapped_ref con WrappedRef : 'a ref -> 'a wrapped_ref - val wrapped_abstract_ref = WrappedRef (abstract_ref); val wrapped_abstract_ref = WrappedRef (ref -) : abstract wrapped_ref - wrapped_abstract_ref = wrapped_abstract_ref; std_in:7.1-7.43 Error: operator and operand don't agree (equality type required) operator domain: ''Z * ''Z operand: abstract wrapped_ref * abstract wrapped_ref in expression: = (wrapped_abstract_ref,wrapped_abstract_ref) - - datatype 'a type_only = TypeOnly; datatype 'a type_only con TypeOnly : 'a type_only - fun equal (x as TypeOnly, y as TypeOnly) = x = y; val equal = fn : ''a type_only * ''a type_only -> bool - (* ^--- doesn't really have to be an equality type *) - Status: not a bug (language problem) ---------------------------------------------------------------------- Number: 536 Title: twig out of date Keywords: Submitter: wgehrke@risc.uni-linz.ac.at (Wolfgang Gehrke) Date: 3/26/92 Version: 0.75 Problem: I had a small trouble to use twig together with this version of ML. There were two problems: 1) The generated code contains identifiers beginning with '_'. 2) I also changed "invoke.sml" to get a stand alone version. Status: fixed in 0.90 ---------------------------------------------------------------------- Number: 537 Title: System.system fails in noshare compiler after Heap extension Keywords: Submitter: Eric Madelaine Date: 3/26/92 Version: 0.75 System: sparc Severity: major Problem: When using an sml "-noshare" system, and after the first "Heap extension", any call to System.system fails with: uncaught exception SystemCall This error does not occur before having the heap extended, nor in a system built without the "-noshare" option, even after many heap extensions. [followup on 3/31/92]: It occurs now in any configuration of my system (may be because it is bigger now). Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 538 Title: uncaught exception subscript during compilation Keywords: Submitter: Dave MacQueen Date: 3/30/92 Version: 0.78 Problem: Code: (* hacked version of code from David Ladd *) (* Variables provide a more sophisticated and better packaged version of ID's *) signature VARIABLES = sig datatype var (* variables *) = PREVBL of string | VBL of {name: string, stamp: int} val varname : var -> string (* following are concerned with "alpha conversion" *) type varenv val newvar: string -> var val empty_env : varenv val lookup : varenv * string -> var option val bind : string * var * varenv -> varenv end structure Variables: VARIABLES = struct (* Rather than represent variables as simple strings, I introduce a variable type (var). The first form (PREVBL) is a temporary variable produced on parsing, and then replaced when static analysis is performed to determine scoping and association between binding and applied occurences of variables. If parsing is made a bit more complicated, this static analysis can be done on the fly during parsing and only the second form of variable would be needed (this is how it is currently done in the ML compiler. For the VBL form, the stamp field is an integer that uniquely identifies that variable. *) datatype var (* variables *) = PREVBL of string | VBL of {name: string, stamp: int} fun varname(PREVBL s) = s | varname(VBL{name,stamp}) = name ^ "." ^ makestring stamp val count = ref 0 fun newvar s = VBL{name=s, stamp=(inc count; !count)} type varenv = (string * var) list val empty_env = [] fun lookup([],_) = NONE | lookup((s,v)::rest,s') = if s = s' then SOME v else lookup(rest,s') fun bind(s,v,env) = (s,v)::env end (* structure Variables *) (* it will probably be more convenient to have a smaller number of cases in the expression datatype. One way of reducing the number of expression constructs is to have an APP constructor that takes an "operator" and a list of argument expressions. If the set of possible operators is fixed, then they may be defined as the constructors of an operator datatype, as below. If new operators can be introduced, then a more complicated operator type would be appropriate. You might look at src/absyn/bareabsyn.sml to see how the ML abstract syntax is defined. Each operator needs to be assigned its arity, and when constructing an expression, or when checking its "well-formedness" (a mild form of type checking), one would verify that the length of the argument list matches the arity of the operator. For proper type checking, each operator would be assigned a type, which would presumably subsume its arity. *) structure Operators = struct datatype operator = PLUS | MINUS | MUL | DIV | MOD | EXP | SHL | SHR | BAND | BOR | XOR | EQ | NEQ | GT | LT | GTE | LTE | AND | OR | IS_IN | UNION | INTERSECTION | SUBSE | SET_EQ | SET_MINUS | MATCH | NOT_MATCH | UMINUS | NOT | BNOT | COUNT | MIN | MAX | SUM (* following function is useful for printing expressions, as in ppexpr *) fun operName PLUS = "plus" | operName MINUS = "minus" | operName MUL = "mul" | operName DIV = "div" | operName MOD = "mod" | operName EXP = "exp" | operName SHL = "shl" | operName SHR = "shr" | operName BAND = "band" | operName BOR = "bor" | operName XOR = "xor" | operName EQ = "eq" | operName NEQ = "neq" | operName GT = "gt" | operName LT = "lt" | operName GTE = "gte" | operName LTE = "lte" | operName AND = "and" | operName OR = "or" | operName IS_IN = "is_in" | operName UNION = "union" | operName INTERSECTION = "intersection" | operName SUBSE = "subse" | operName SET_EQ = "set_eq" | operName SET_MINUS = "set_minus" | operName MATCH = "match" | operName NOT_MATCH = "not_match" | operName UMINUS = "uminus" | operName NOT = "not" | operName BNOT = "bnot" | operName COUNT = "count" | operName MIN = "min" | operName MAX = "max" | operName SUM = "sum" fun arity(oper: operator) : int = case oper of UMINUS => 1 | NOT => 1 | BNOT => 1 | COUNT => 1 | MIN => 1 | MAX => 1 | SUM => 1 | _ => 2 end (* structure Operators *) open Variables Operators (* the rest of this should be packaged in structures too, but its getting late so I'm not going to finish it. *) datatype exp = INT of int (* was CONST *) | STR of string | ENUM of string (* probably want something more specialized than string *) | VAR of var (* was ID *) | QUES of exp * exp * exp | SET of exp list | APP of operator * exp list (* val test = PLUS(CONST(4),CONST(3)); *) val test = APP(PLUS,[INT 4, INT 3]) datatype stmt = ASSERT of exp | FOR of var * exp * stmt | CMPD of stmt list; val testprog = FOR(PREVBL "x",SET([INT(1),INT(2)]), ASSERT(APP(EQ,[VAR(PREVBL "x"),INT 0]))); val testprog2 = FOR(PREVBL "x", SET([INT 1, INT 2]), CMPD([ ASSERT(APP(EQ,[VAR(PREVBL "x"),INT 0])), FOR(PREVBL "x", SET([INT(3),INT(4)]), ASSERT(APP(NEQ,[VAR(PREVBL "x"),INT 1])) ), ASSERT(APP(NEQ,[VAR(PREVBL "x"),INT 1])) ]) ); (* for some useful printing utilities, you might look at src/basics/printutil.sml in the ML source code. But much more sophisticated pretty-printing support is likely to become available soon. *) (* all this concatenating of strings (in a quadratic fashion), is liable to get expensive if you start printing big objects. It is probably more efficient to print directly rather than build a string. There will be an sprintf-style facility in the new library we are building, so you could print "into" a string in a linear fashion. *) (* in src/absyn/printabsyn.sml you can find our rather crude pretty printer for ML abstract syntax. It attempts to cope with infix operators and their precedences and other complications. *) fun prvar (PREVBL s) = s | prvar (VBL{name,stamp}) = name ^ "." ^ makestring stamp fun ppexpr (APP(EQ,[a,b])) = ppexpr a ^" == "^ ppexpr b | ppexpr (APP(NEQ,[a,b])) = ppexpr a ^" != "^ ppexpr b | ppexpr (INT i) = makestring i | ppexpr (STR s) = "\"" ^ s ^ "\"" | ppexpr (VAR v) = prvar v | ppexpr (SET l) = "{" ^ pplist l ^ "}" | ppexpr (QUES(e1,e2,e3)) = "if " ^ ppexpr e1 ^ " then " ^ ppexpr e2 ^ " else " ^ ppexpr e3 | ppexpr (APP(oper,args)) = operName oper ^ "(" ^ pplist args ^ ")" (* here you see the advantage of separating out the operators *) and pplist ([h]) = ppexpr h (* shorthand for h::[] *) | pplist (h::t) = ppexpr h ^ "," ^ pplist t | pplist [] = "" (* this could be made a bit more efficient. We probably need to provide a primitive to efficiently build such strings. fun sp 0 = "" | sp n = " " ^ sp (n - 1); Below is a somewhat faster version (especially as n gets larger. *) fun sp n = let fun collect(0,l) = l | collect(n,l) = collect(n-1," "::l) in implode(collect(n,[])) end fun ppstmt (t,ASSERT(x)) = "\n" ^ sp t ^ ppexpr x ^ ";" | ppstmt (t,FOR(a,b,c)) = "\n"^ sp t ^"for " ^ (varname a) ^ " in " ^ ppexpr b ^ ppstmt(t+1,c) | ppstmt (t,CMPD(nil)) = "" | ppstmt (tab,CMPD(l)) = let fun pplist (h::t) = ppstmt(tab,h) ^ pplist t | pplist [] = "" in " begin" ^ pplist l ^ "\n" ^ sp (tab - 1) ^ "end" end; fun prt (ex) = output(std_out,ppstmt(0,ex) ^ "\n"); (* to complete this evaluator sensibly you need a more general notion of the values that your expressions can evaluate to. Presumably you need to deal with strings, booleans, and set values in addition to integers. The value type will probably be a datatype. *) datatype value = INTval of int | STRval of string | BOOLval of bool | SETval of value list (* allows heterogeneous sets, which probably don't occur. *) fun seval (INT x) = INTval x | seval (APP(PLUS,[a,b])) = let val INTval va = seval a and INTval vb = seval b in INTval(va+vb) end | seval (APP(MINUS,[a,b])) = let val INTval va = seval a and INTval vb = seval b in INTval(va-vb) end | seval (QUES(x,y,z)) = let val INTval vx = seval x and INTval vy = seval y and INTval vz = seval z in INTval(if vx <> 0 then vy else vz) end | seval (_) = INTval 0; (* ??? *) (* what types of values does an operator like EQ apply to? If it is overloaded, and can apply to, say, integers and strings, then the evaluation rule has to do a case analysis: | seval (APP(EQ,[a,b])) = case seval a of INTval va => (case seval b of INTval vb => BOOLval(va = vb) | _ => raise TypeError) | STRval va => (case seval b of STRval vb => BOOLval(va = vb) | _ => raise TypeError) | ... *) fun eaconv env (e as VAR(PREVBL x)) = (case lookup(env,x) of SOME v => VAR v | NONE => e) | eaconv env (APP(oper,args)) = APP(oper, map (eaconv env) args) | eaconv env (QUES(e1,e2,e3)) = QUES(eaconv env e1, eaconv env e2, eaconv env e3) | eaconv env (SET elems) = SET(map (eaconv env) elems) | eaconv env e = e fun alphasub (env,ASSERT(x)) = ASSERT(eaconv env x) | alphasub (env,CMPD(l)) = let fun mapped(x) = alphasub(env,x) in CMPD(map mapped l) end | alphasub (env,FOR(PREVBL a, b, c)) = let val new = newvar a in FOR(new, (eaconv env b), alphasub( bind(a,new,env), c)) end | alphasub (env,stmt) = stmt; fun aconv(x) = alphasub(empty_env,x); Status: fixed in 0.83 ---------------------------------------------------------------------- Number: 539 Title: weak typing bug Keywords: Submitter: John Greiner Date: 4/2/92 Version: 0.75 Severity: major Problem: weak typing failure Transcript: - (let val x = ref nil in fn y => x end) (); val it = ref [] : '1a list ref - let val a = (let val x = ref nil in fn y => x end) () in = a:=[1]; hd(!a)^"hi" end; val it = "\^Ahi" : string In V.73 (I think) this wasn't there, as I have referenced in a file: - (let val x = ref nil in fn y => x end) (); std_in:2.1-2.41 Error: nongeneric weak type variable it : '~1Z list ref Status: fixed in 0.89 ---------------------------------------------------------------------- Number: 540 Title: printing hanging on Mach Keywords: Submitter: Bob Harper Date: 4/2/92 Version: 0.78 System: DecStation 5000, Mach, running over telnet Severity: major Problem: Type "structure S = System". On my machine it prints about halfway through, then hangs. Comment: Sometimes when running sml over a telnet, the printing hangs. You can continue by typing space. This is not new to 0.78. [Gene Rollins] [Bob Harper, 4/11/92]: Incidentally, on the PMAX (at least) I consistently get the following behavior. I type in something, particularly something that incurs a type error. I get back half or three quarters of a message, then it hangs. The only way out is to type ^C, which gets me back to the prompt. If I type the same thing again, I may or may not get the full message. Often I just kill the session and start over, then it works (for a while). We're running Mach on the PMAX, and I'm using ML via telnet, within an emacs ML interaction window, if it matters. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 541 Title: warnings while compiling runtime Keywords: Submitter: Kai Kein{nen Date: 4/5/92 Version: 0.80 from research.att.com:/dist/ml/working on April 5 System: RISC/OS 4.52, MIPS RC 6280 Severity: minor Problem: compilation time warnings for gc.c and prim.s Code: ./makeml -mips riscos Transcript: ./makeml> (cd runtime; make clean) rm -f *.o lint.out prim.s linkdata allmo.s run ./makeml> rm -f mo ./makeml> ln -s ../mo.mipsb mo ./makeml> (cd runtime; rm -f run allmo.o allmo.s) ./makeml> (cd runtime; make MACHINE=MIPS 'CFL= -systype bsd43' 'LIBS=' 'DEFS= -DRISCos -DRUNTIME=\"runtime\"' linkdata) cc -O -systype bsd43 -DMIPS -DRISCos -DRUNTIME=\"runtime\" -o linkdata linkdata.c ./makeml> runtime/linkdata [runtime/IntMipsBig.mos] runtime/linkdata> as runtime/allmo.s -o runtime/allmo.o ./makeml> (cd runtime; make MACHINE=MIPS 'DEFS= -DRISCos' 'CPP=/lib/cpp -P' 'CFL= -systype bsd43' 'AS=as' 'LIBS=') cc -O -systype bsd43 -DMIPS -DRISCos -c run.c cc -O -systype bsd43 -DMIPS -DRISCos -c run_ml.c cc -O -systype bsd43 -DMIPS -DRISCos -c callgc.c cc -O -systype bsd43 -DMIPS -DRISCos -c gc.c uopt: Warning: gc: this procedure not optimized because it exceeds size threshold; to optimize this procedure, use -Olimit option with value >= 886. cc -O -systype bsd43 -DMIPS -DRISCos -c MIPS.dep.c cc -O -systype bsd43 -DMIPS -DRISCos -c export.c cc -O -systype bsd43 -DMIPS -DRISCos -c timers.c cc -O -systype bsd43 -DMIPS -DRISCos -c ml_objects.c cc -O -systype bsd43 -DMIPS -DRISCos -c cfuns.c cc -O -systype bsd43 -DMIPS -DRISCos -c cstruct.c cc -O -systype bsd43 -DMIPS -DRISCos -c signal.c cc -O -systype bsd43 -DMIPS -DRISCos -c exncode.c cc -O -systype bsd43 -DMIPS -DRISCos -c malloc.c cc -O -systype bsd43 -DMIPS -DRISCos -c mp.c cc -O -systype bsd43 -DMIPS -DRISCos -c sync.c /lib/cpp -P -DASM -DMIPS -DRISCos MIPS.prim.s > prim.s as -o prim.o prim.s as0: Warning: prim.s, line 305: missing .end preceding this .ent: set_request .ent set_request as0: Warning: prim.s, line 305: .ent/.end block never defined the procedure name as0: Warning: prim.s, line 434: missing .end preceding this .ent: go .ent go Comments: Some of the corrections needed earlier for MIPS R6000 seem to be missing from this version. The interpreter seems to work correctly in spite of these warnings. Status: fixed in 0.90 ---------------------------------------------------------------------- Number: 542 Title: lack of environment cleanup in 0.80 Keywords: Submitter: schristensen@daimi.aau.dk (Soren Christensen) Date: 4/6/92 Version: 0.80 Severity: major Problem: The other question is related to a problem I had in 0.75: >fun x 0 = () | x n = (use_stream (open_string "3"); x (n-1)); >fun test () = (exportML "pre"; x 1000; exportML "post"); > >Try test(); and check the diff in size of pre and post. There seems to be a more grneral problem in 0.80. The toplevel environment seems to grow - even if I do not declare new names. Now that I can inspect the valuse in the environmet I find "VAL$it" repeted. try: map (fn x => print (System.Symbol.makestring x))(System.Env.catalogEnv (System.Env.staticPart (!System.Env.topLevelEnvRef))); Especially after running for a while. Status: fixed in 0.82 ---------------------------------------------------------------------- Number: 543 Title: top-level printing fails Keywords: Submitter: Bob Harper Date: 4/8/92 Version: ? Severity: major Problem: Code: type OrdId = string type ModId = string datatype Ord = Kind | Type | Pi of Dec * Ord | Abs of Dec * Ord | App of Ord * Ord | Cast of Ord * Ord | One | Sub of Ord * Sub | Fst of Mod and Mod = KindM | Signature | PiM of DecM * Mod | AbsM of DecM * Mod | AppM of Mod * Mod | OneM | CastM of Mod * Mod | SubM of Mod * Sub | Nil | NilSig | OTuple of Def * Mod | OTupleSig of Dec * Mod | RTuple of DefM * Mod | RTupleSig of DecM * Mod | FstM of Mod | SndM of Mod and Sub = Id | Shift | ODef of Sub * (OrdId * Ord * Ord option) | MDef of Sub * (ModId * Mod * Mod option) | Comp of Sub * Sub and Ctx = Null | ODec of Ctx * Dec | MDec of Ctx * DecM and Dec = Dec of OrdId * Ord and Def = Def of OrdId * Ord and DecM = DecM of ModId * Mod and DefM = DefM of ModId * Mod ; Transcript: I type: val S = OTupleSig(Dec("t",Type),NilSIg); I get: val S = OTupleSig ( uncaught exception Subscript The actual input is much larger: I build the system using SourceGroup, then open the structure IntSyn, which makes available this datatype, which then results in the exhibited behavior. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 544 Title: poor error message Keywords: Submitter: John Reppy Date: 4/16/92 Version: 0.81 Severity: minor Problem: The error message Error: non-constructor applied to argument in pattern would be much more useful if it gave the name of the identifier. Comment: [dbm, 10/7/92] There are two places where this message was generated. In elabutil.sml code has been added to print the bogus rator. In astutil.sml the message has been changed to "nonidentifier applied to argument in pattern", but bogus pattern is not printed because there is no ast printer yet. Status: fixed in 0.93 (?) ---------------------------------------------------------------------- Number: 545 Title: signature matching looping? Keywords: Submitter: Amy Moormann Zaremski Date: 3/5/92 Version: .75 (both with and without sourcegroup) System: Dec 3100, Mach ??(whatever default is right now) Severity: minor Problem: Certain signature/structure combinations cause SML to "loop" (grow the heap until memory is exhausted). Code: signature S = sig val f : 'b -> int end structure S1:S = struct fun f x = x end Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - signature S = sig = val f : 'b -> int = end; signature S = sig val f : 'a -> int end - structure S1:S = struct = fun f x = x = end; [Major collection... [Increasing heap to 2478k] [Increasing heap to 4798k] 92% used (1550460/1673392), 1188 msec] [Increasing heap to 7002k] [Major collection... 74% used (2960732/3949436), 2797 msec] [Increasing heap to 11582k] [Major collection... [Increasing heap to 17730k] 80% used (5808988/7231036), 5062 msec] [Increasing heap to 21198k] [Major collection... [Increasing heap to 32438k] 80% used (10635356/13238652), 9407 msec] [Increasing heap to 32634k] [Major collection... 73% used (13238652/17984796), 12468 msec] [Increasing heap to 32710k] [Major collection... [Increasing heap to 32734k] [Increasing heap to 32746k] [Increasing heap to 32750k] [Increasing heap to 32754k] Warning: can't increase heap Ran out of memory Process Inferior smlsg exited abnormally with code 3 Status: fixed in 0.83 ---------------------------------------------------------------------- Number: 546 Title: System.architecture not initialized Keywords: Submitter: Gene Rollins, Dave MacQueen Date: 4/24/92 Version: 0.81 Severity: minor Problem: System.architecture not initialized because comment brackets in cps/shareglue.sml haven't been removed. Status: fixed in 0.81 ---------------------------------------------------------------------- Number: 547 Title: interrupt not working (inside emacs) Keywords: Submitter: slind@research.att.com Date: 4/27/92 Version: 81 System: mips (It doesn't occur on the sun4) Severity: major Problem: 1) In gnu emacs, sml goes into an infinite loop when I hit the interrupt key, i.e., on the DEL character. Then sml seems to ignore signals: the only way to regain control is to kill the sml process. Merely exiting emacs will not kill the sml process. 2) A related problem is that interrupt doesn't give the right exception (and not until a carriage return): it returns the Abort exception. Transcript: 1) (Inside gmacs.) $ sml Standard ML of New Jersey, Version 0.81, 9 April 1992 Arrays have changed; see Release Notes val it = () : unit - \003 \003 \004 2) (In the shell) $ sml Standard ML of New Jersey, Version 0.81, 9 April 1992 Arrays have changed; see Release Notes val it = () : unit - std_in:3.1 Error: illegal token uncaught exception Abort - Status: fixed in 0.82 (same as 550) ---------------------------------------------------------------------- Number: 548 Title: blast_read on ints Keywords: Submitter: slind@research.att.com Date: 4/28/92 Version: 75, 81 System: mips and sparc at least; probably all Severity: minor Problem: System.Unsafe.blast_X (where X probably = "read", but I'm not sure). Solitary ints aren't handled properly: in 81, core gets dumped; in 75, the wrong value is returned. Transcript: In 81: $ sml Standard ML of New Jersey, Version 0.81, 9 April 1992 Arrays have changed; see Release Notes val it = () : unit - val outs = open_out "foo"; val outs = - : outstream - System.Unsafe.blast_write(outs,1); [Major collection...abandoned] val it = () : unit - close_out outs; val it = () : unit - val ins = open_in "foo"; val ins = - : instream - System.Unsafe.blast_read ins : int; Memory fault - core dumped $ In 75: - val outs = open_out "foo"; val outs = - :outstream - System.Unsafe.blast_write(outs,1); [Major collection...abandoned] val it = () :unit - close_out outs; val it = () :unit - val ins = open_in "foo"; val ins = - :instream - System.Unsafe.blast_read ins : int; val it = 3242475 :int - Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 549 Title: Match exception while compiling Keywords: Submitter: jont@uk.co.harlqn Date: 28/04/92 Version: SML of NJ version 0.75 System: Sun 4/330 with SunOS 4.1.1 Severity: minor Transcript: - val _ = =; std_in:1.9 Error: nonfix identifier required uncaught exception Match Comment: I guess this shouldn't happen. It's not the sort of thing I type regularly, I was prompted to do it by the compiler's habit of inserting = all over the place when it thinks I've left out an identifier. Comment: in 0.89 produces following - val _ = = ; std_in:0.0 Error: nonfix identifier required Error: Compiler bug: elabVB - Status: fixed in 0.91 (dbm) ---------------------------------------------------------------------- Number: 550 Title: interrupt on MIPS Keywords: Submitter: Lal George Date: 4/29/92 Version: 0.81 System: MIPS/Riscos 4.52 Severity: major Problem: 0.81 on the MIPS has problems with signal handling. An interrupt (ctrl-c) causes it to go into deep space, eating up cpu time. Status: fixed in 0.82 ---------------------------------------------------------------------- Number: 551 Title: large integers yield Illegal instruction Keywords: Submitter: Kjeld H. Mortensen | Email: kjeld@metasoft.com Date: 4/29/92 Version: 0.81 System: ? Severity: major Problem: Large integer literal causes illegal instruction. Transcript: metasparc 141 : /d1/tools/njsml/81/sml.sparc.ns Standard ML of New Jersey, Version 0.81, 9 April 1992 Arrays have changed; see Release Notes val it = () : unit - 536870911; val it = 536870911 : int - 536870912; Illegal instruction metasparc 142 : Comments: 536870912 seems to be 2^29. (Similar behaviour, of course, for corresponding negative numbers.) This compiler was build with 'makeml -noshare' on a Sun4, but compilers build with 'makeml' have same behaviour. In SML/NJ v0.80 this is no problem. Here integers can be up to (2^30)-1 and it doesn't give 'Illegal instruction'. Status: fixed in 0.81 (?) ---------------------------------------------------------------------- Number: 552 Title: Error message line numbers from std_in (see also 575) Keywords: Submitter: Lal George Date: 4/30/92 Version: 0.81 System: all Severity: major Problem: Error line numbers are incorrect in the interactive session. Transcript: Standard ML of New Jersey, Version 0.81, 9 April 1992 Arrays have changed; see Release Notes val it = () : unit - val x = 1; val x = 1 : int - fun f x = val y = 2 in x + y end; --> std_in:4.11 Error: syntax error found at VAL - val x = 3; val x = 3 : int - val x = 4; val x = 4 : int - fun f x = val y = 2 in x + y end; --> std_in:6.12 Error: syntax error found at VAL Comments: This is a nuisance for programs that do regression testing, or under emacs ML-mode. Status: fixed in 0.91 ---------------------------------------------------------------------- Number: 553 Title: incorrect syntax accepted Keywords: Submitter: John Reppy Date: 4/30/92 Version: 0.81a Severity: minor Problem: The following things are not legal SML syntax, but we accept them: Transcript: Standard ML of New Jersey, Version 0.81, 9 April 1992 Arrays have changed; see Release Notes val it = () : unit - let in 1 end; val it = 1 : int - let ; in 1 end; val it = 1 : int - let ;;; in 1 end; val it = 1 : int - Fix: change "LET ldecs IN " to "LET ldec ldecs IN" Note that there are probably two places where this occurs; the other is "LET sdecs IN" or something like that. Note: the Definition allows an "empty declaration" so this isn't a bug. Status: not a bug ---------------------------------------------------------------------- Number: 554 Title: unused token constructor QUERY Keywords: Submitter: John Reppy Date: 4/29/92 Version: 0.81a Severity: trivial Problem: I notice that there is a terminal symbol named QUERY declared in ml.grm, which is never used. Fix: remove QUERY constructor Status: fixed in 0.90 ---------------------------------------------------------------------- Number: 555 Title: window signal Keywords: Submitter: John Reppy (jhr@research.att.com) Date: 5/8/92 Version: versions 75-81 (at least) System: RISCOS (R3000 & R6000) Severity: major Problem: resizing a shell window (xterm or cmdtool) that is running sml causes the sml process to either die or go into an infinite loop. Comments: This is likely a problem with the handling of WINCH signals, but it doesn't seem to be related to the general problems with signals on the MIPS in 0.81. Status: fixed in 0.82 ---------------------------------------------------------------------- Number: 556 Title: large integers on Sparc Keywords: Submitter: Date: 5/12/92 Version: System: Severity: Problem: Code: < 0x80000000 > Transcript: < Standard ML of New Jersey, Version 0.81, 9 April 1992 Arrays have changed; see Release Notes val it = () : unit - 100000 * 100000; Illegal instruction > Status: fixed in 0.83 ---------------------------------------------------------------------- Number: 557 Title: sparc signals Keywords: Submitter: Andre Kramer akramer@ecrc.de Date: 5/14/92 Version: 0.75 System: sparc Severity: Problem: asynchronous exceptions for sparc file SPARC.prim.s _savefpregs retl nop does nothing. in signal.c /* * save floating point registers. */ savefpregs(msp); fpregs = ((int *)(msp->ml_allocptr)) + 1; msp->ml_allocptr += (NSAVED_FPREGS*2 + 1) * sizeof(int); allocates 1 word from heap and later saves a pointer to it (fpregs). this word should contain a descriptor (len 0,tag string): Fix: (MAKE_DESC(NSAVED_FPREGS*8,tag_string)) as is done in _savefpregs for the M68, MIPS. (VAX is same as Sparc). Comments: I have a another question on the new calling conventions (CALLEESAVE) for sparc. If register masks in code strings don't contain the CLOSURE_INDX the last bit is 0. A mask then either looks like a pointer or an int. Does this not affect the garbage collector? Status: fixed in 0.81 --- some version between 0.75 and 0.81 ---------------------------------------------------------------------- Number: 558 Title: local...end structure expressions not working in 0.80 Keywords: Submitter: Tim Freeman, tsf@cs.cmu.edu Date: 5/15/92 Version: 0.80 System: Sun 4 running Mach Severity: minor Problem: The new compiler doesn't know that local...end is sensible at the structure level. Transcript: val it = () : unit - System.Compile.makeSource ("foo",1,std_in,true,std_out); val it = prim? : source - val staticEmpty = System.Env.staticPart (System.Env.emptyEnv ()); val staticEmpty = prim? : staticEnv - val s = System.Compile.makeSource ("foo",1,std_in,true,std_out); val s = prim? : source - System.Compile.compile (s,staticEmpty); - local = structure x = struct val z = 3 end = in = structure y = struct val w = x.z end = end; uncaught exception Compile Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 559 Title: static environment not cleaned up Keywords: Submitter: Dave MacQueen Date: 5/17/92 Version: 0.81 Severity: average Problem: Top level static environment is not consolidated in the interactive loop, so hidden static bindings are not removed and static environment grows too fast. Fix: Add a call of Environment.consolidate when newenv is built at the end of function evalLoop in functor Interact (build/interact.sml). Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 560 Title: blast functions and separate compilation Keywords: Submitter: Emden R. Gansner, erg@ulysses.att.com Date: 5/18/92 Version: 0.81c System: Sparc 2, SunOS 4.1 Severity: major Problem: Separate compilation facility is broken Code: structure SepComp = struct val fname = "a.o" fun compFile () = let open System.Compile System.Env val targetWrite : (outstream * compUnit) -> unit = System.Unsafe.blast_write val staticPerv = staticPart(!pervasiveEnvRef) val sourceF = open_string "structure A = struct end" val source = makeSource("", 1, sourceF, false, std_out) val compUnit as (static, code) = (compile(source,staticPerv)) handle e => (closeSource source; raise e) val outstr = open_out fname in targetWrite (outstr, compUnit); closeSource source; close_out outstr end fun loadFile () = let open System.Compile val targetRead : instream -> compUnit = System.Unsafe.blast_read val instr = open_in fname val effectiveEnv = !System.Env.pervasiveEnvRef val _ = print "starting load \n" val (staticUnit,codeUnit) = targetRead instr in print "readUnit done \n"; close_in instr; print "starting execute \n"; execute((changeLvars staticUnit,codeUnit), effectiveEnv); print "finished execute \n" end end val _ = SepComp.compFile () val _ = SepComp.loadFile () Transcript: loadFile hangs during execute; sending an interrupt signal produces a core dump Comments: This program works fine in 0.80. Changes made to blast_read and blast_write in 0.81 are probably the root of the problem. The above program also failed in 0.81b, but hung during blast_read. This was mentioned to Lal, who, I believe, produced 0.81c as a partial fix. Status: fixed in 0.82 ---------------------------------------------------------------------- Number: 561 Title: exportFn images too big (same as 489) Keywords: Submitter: Andrew Koenig Date: 5/19/92 Version: 0.75 System: Sparc Severity: minor Problem: For practical reasons, it would be nice to get exportFn to create less bulky executables for small programs. For example, here is a somewhat simplified version of the `echo' command: fun echo [] = print "\n" | echo (h::nil) = print (h^"\n") | echo (h::t) = (print(h ^ " "); echo t) fun main(argv, envp) = echo(tl argv) When I use `exportFn' to make an executable of this, it takes 136 kbytes using 0.53 on a 10th Edition machine. Using 0.75 on a Sparcstation, the executable is 471 kbytes. Even if we allow that Sparc executables are bigger, it is hard to believe that that much baggage is truly necessary. [from ark, 12/1/92:] I just built 0.92 and gave it a try. When built with -noshare, the following fun main _ = print "Hello world\n"; exportFn ("xxx", main); yields a 946K executable with 860K of loadable data. This is as opposed to 376K/249K with 0.75, which in turn was about twice as big as 0.43. [from Lal, 12/16/92] We mercifully had the result of exportFn for the lego theorem prover using version 0.66. So I built a noshare version of sml for the Sparc and rebuilt lego using version 0.92. There is more than a Mbyte increase in the size of the exported image. Below, Olego is the image under 0.66, and lego is the version under 0.92. Either this is to be expected - which is bad, or there are references that are not being cleared - which is also bad. ---------------------------------------------------------------- lutece:$ ls -l total 3104 -rwxrwxrwx 1 dbm 999456 Mar 26 1991 Olego* -rwxr-xr-x 1 george 2146336 Dec 16 18:38 lego* Status: fixed in 0.93c ---------------------------------------------------------------------- Number: 562 Title: SML hanging under telnet (under Mach) (also #540) Keywords: Submitter: tsf@cs.cmu.edu Date: 5/19/92 Version: 0.80 System: Pmax, running Mach. Also Sun 4's running mach, but more rarely. (I'm referring to the type of the machine running SML, not the type of the machine running telnet.) Severity: minor Problem: When running under telnet, sml intermittently hangs on output. Code: Anything that produces lots of output will do. Transcript: It's long, so I put it at the end of this message. It's not very informative. Comments: If I say "sml | cat -u" instead of "sml", things work fine. If I create a remote xterm and run sml within that, or a remote gnu-emacs and run sml within that, things work fine. The problem only happens when sml's standard output is a pty controlled by telnet. The type of the machine running sml seems to make more of a difference than the type of the machine at the other end of the telnet connection. Fix: Say "sml | cat -u" instead of "sml" to invoke sml at the other end of a telnet connection. Looking at the code for flushbuf in boot/perv.sml, I see that you wait for output to become possible before sending the first bytes of output, but inside the loop in write_all in runtime/cfuns.c, you don't wait for output to become possible after a partial write. This discrepancy is strange, but I don't see how it could give rise to this bug. Do you use nonblocking IO? Why do you wait for output to become possible before starting a write? I wouldn't be surprised if telnet is the only device you output to that doesn't always write all of the bytes you ask it to. Here's the transcript. The details don't matter much, anything that produces this much chatter is very likely to hang. This works fine when run locally or when piped through "cat -u". % telnet desert.fox Trying 128.2.206.48... Connected to DESERT.FOX.CS.CMU.EDU. Escape character is '^]'. DESERT.FOX.CS.CMU.EDU TCP Telnet service. 4.3 BSD UNIX (DESERT.FOX.CS.CMU.EDU) (ttyP0) login: tsf Password: Last login: Thu May 14 13:11:17 from 128.2.222.175 (*Unknown*) This login: Tue May 19 14:28:07 from 128.2.222.175 (*Unknown*) % sml-sg Standard ML of New Jersey, Version 0.80, April 2, 1992 with SourceGroup 2.1b built on Fri May 8 10:02:15 EDT 1992 val it = () : unit - use "load.sml"; [closing /afs/cs/user/tsf/sml/lib/setparams.sml] Eof val it = () : unit /afs/cs/user/tsf/sml/lib/link.sml /afs/cs/user/tsf/sml/lib/subst.sig.sml /afs/cs/user/tsf/sml/lib/subst.sml /afs/cs/user/tsf/sml/lib/util.sig.sml /afs/cs/user/tsf/sml/lib/util.sml val libg = 1 : ?.group val makeload = fn : unit -> unit [closing /afs/cs/user/tsf/sml/lib/lib.sml] Eof val it = () : unit refine.lex.sml refine.grm.sig refine.grm.sml unify.sml unify.sig.sml term.sml term.sig.sml subtypedata.sml subtypedata.sig.sml subtype.sml subtype.sig.sml parse.sml parse.sig.sml mltype.sml mltype.sig.sml link.sml interface.sml interface.sig.sml interactive.sml base.sml absyn.sml absyn.sig.sml refine.lex refine.grm val newg = 3 : ?.group val loadref = fn : unit -> unit [reading /afs/cs/user/tsf/sml/lib/.@sys/util.sig.sml.bin] signature UTIL [reading /afs/cs/user/tsf/sml/lib/.@sys/util.sml.bin] functor Util [reading /afs/cs/user/tsf/sml/lib/.@sys/subst.sig.sml.bin] signature SUBST [reading /afs/cs/user/tsf/sml/lib/.@sys/subst.sml.bin] functor Subst [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/term.sig.sml.bin] signature TERM [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/unify.sig.sml.bin] signature UNIFY [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/unify.sml.bin] functor Unify [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/term.sml.bin] functor Term [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/subtypedata.sig.sml.bin] signature SUBTYPEDATA [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/subtypedata.sml.bin] functor SubtypeData [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/mltype.sig.sml.bin] signature MLTYPE [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/subtype.sig.sml.bin] signature SUBTYPE [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/subtype.sml.bin] functor Subtype [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/base.sml.bin] signature LR_PARSER functor Join signature ARG_PARSER signature STREAM signature FIFO functor JoinWithArg signature TOKEN signature PARSER_DATA signature LR_TABLE signature PARSER signature LEXER signature ARG_LEXER [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/refine.grm.sig.bin] signature Refine_LRVALS signature Refine_TOKENS [reading /afs/cs.cmu.edu/project/ergo-tsf/sml/thesis/.@sys/interface.sig.sml.bin] (and it hanged here! Pressing ^C unhangs it and returns me to the top level.) Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 563 Title: trig functions return garbage on large args Keywords: Submitter: Andrzej Filinski, andrzej@cs.cmu.edu Date: 5/29/92 Version: 0.75 (also in 0.80) System: all Severity: minor Problem: trig. functions return huge, random results for arguments greater than approx. 6.747E9 (= 2 pi * maxint). Transcript: Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - sin 6.746E9; val it = 0.577192771297902 : real (* correct to about 6 significant digits, as expectable *) - sin 6.747E9; val it = ~1.17525075405876E64 : real Comments: The problem seems to be with the overflow handling in rtoi/drem, file boot/math.sml. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 564 Title: problems on HP9000s400 Keywords: Submitter: Kjeld H. Mortensen (kjeld@metasoft.com) Date: 6/2/92 Version: 0.81 System: HP9000s400, HPUX 8.0, 32Mb ram, >70Mb swap Severity: minor (but might be major for other people) Problem: Bug in sun2hp.el Code: Do a 'makeml -m68 hpux8' Transcript: neptune 125 : makeml -m68 hpux8 makeml> (cd runtime; make clean) rm -f *.o lint.out prim.s linkdata allmo.s run makeml> rm -f mo makeml> ln -s ../mo.m68 mo makeml> (cd runtime; rm -f run allmo.o allmo.s) makeml> (cd runtime; make MACHINE=M68 'CFL=-Wl,-a,archive' 'LIBS=' 'DEFS= -DHPUX -DRUNTIME=\"runtime\"' linkdata) cc -g -Wl,-a,archive -DM68 -DHPUX -DRUNTIME=\"runtime\" -o linkdata linkdata.c (cd runtime; grep -v mo/Math.mo IntM68.mos > Tmp.mos) makeml> runtime/linkdata [runtime/Tmp.mos] runtime/linkdata> as runtime/allmo.s -o runtime/allmo.o makeml> (cd runtime; ...) makeml> /lib/cpp -DCALLEESAVE=0 -DM68 -DHPUX -DASM M68.prim.s > prim.s makeml> emacs -batch -l sun2hp.el prim.s prim.s label <2> has moved makeml> as -o prim.o prim.s as error: "prim.s" line 255: invalid instruction mnemonic (.text) as error: "prim.s" line 255: syntax error [...rest of error msgs deleted...] Comments: "label <2> has moved" is printed by the LISP fn replace-all-label-definitions. It gets confused because there are more than one label on a line (this kind of lines with multible labels are produced by the (new) macro "CHECKLIMIT" in M68.prim.s). Fix: Replace replace-all-label-definitions with the following fn: (the fix does the following: instead of moving to the beginning of the line in order to search for the label, the pointer is only moved 2 chars to the left of the label.) ;; replace-all-label-definitions -- change each of the old label ;; definitions to their new value. ;; (defun replace-all-label-definitions (labels) (while labels (let* ((cur (car labels)) (old-label (label-old-label cur)) (point (label-point cur)) (new-label (label-new-label cur))) (goto-char (- point 2)) (re-search-forward "\\([0-9]+\\):" (point-max) t) (if (not (string-equal (buffer-substring (match-beginning 1) (match-end 1)) old-label)) (error "label <%s> has moved" old-label) (replace-match (concat new-label ":")))) (setq labels (cdr labels)))) [Reppy:] Probably the easiest fix for this is to change the CHECKLIMIT macro to #define CHECKLIMIT \ 1: \ jgt 2f; \ lea 1b,a5; \ rts; \ 2: [Mortensen:] I don't think this will work since /lib/cpp on the HP9000s400 (at least on ours) converts CHECKLIMIT into 1: jgt 2f; lea 1b,a5; rts; 2: If sun2hp.el is fixed, anybody can make changes to M68.prim.s without having to remember that multible labels on a line are not allowed, just because the translator algorithm in sun2hp.el cannot handle it. Status: fixed in 0.87 ---------------------------------------------------------------------- Number: 565 Title: System.Directory.listDir on SGI Keywords: Submitter: John Reppy (jhr@research.att.com) Date: 6/4/92 Version: 0.81 System: SGI 3D/480, SGI Crimson (Irix 4.0.1, 4.0.4) Severity: major Problem: Using the function System.Directory.listDir causes sml to go into an uninterruptable infinite loop. Transcript: Standard ML of New Jersey, Version 0.81, 15 May 1992 val it = () : unit - System.Directory.listDir "."; Comments: This code often seems to be flakey. Maybe we should switch to using the underlying OS code. Status: fixed in 0.93 ---------------------------------------------------------------------- Number: 566 Title: An addition to sun2hp.el (?) Keywords: Submitter: Kjeld H. Mortensen (kjeld@metasoft.com) Date: 6/2/92 Version: 0.81 System: HP9000s400, HPUX 8.0, 32Mb ram, >70Mb swap Severity: minor (but might be major for other people) Problem: Tranlation entry missing in sun2hp.el Code: Do a 'makeml -m68 hpux8' with the fix to sun2hp.el I send earlier Transcript: neptune 126 : makeml -m68 hpux8 makeml> (cd runtime; make clean) rm -f *.o lint.out prim.s linkdata allmo.s run makeml> rm -f mo makeml> ln -s ../mo.m68 mo makeml> (cd runtime; rm -f run allmo.o allmo.s) makeml> (cd runtime; make MACHINE=M68 'CFL=-Wl,-a,archive' 'LIBS=' 'DEFS= -DHPUX -DRUNTIME=\"runtime\"' linkdata) cc -g -Wl,-a,archive -DM68 -DHPUX -DRUNTIME=\"runtime\" -o linkdata linkdata.c (cd runtime; grep -v mo/Math.mo IntM68.mos > Tmp.mos) makeml> runtime/linkdata [runtime/Tmp.mos] runtime/linkdata> as runtime/allmo.s -o runtime/allmo.o makeml> (cd runtime; ...) makeml> /lib/cpp -DCALLEESAVE=0 -DM68 -DHPUX -DASM M68.prim.s > prim.s makeml> emacs -batch -l sun2hp.el prim.s prim.s Wrote /d1/release/tools/njsml/workatt81/src/runtime/prim.s makeml> as -o prim.o prim.s as error: "prim.s" line 420: invalid instruction mnemonic (jpl) as error: "prim.s" line 420: syntax error as error: "prim.s" line 458: invalid instruction mnemonic (jpl) as error: "prim.s" line 458: syntax error as error: "prim.s" line 479: invalid instruction mnemonic (jpl) as error: "prim.s" line 479: syntax error as error: "prim.s" line 500: invalid instruction mnemonic (jpl) as error: "prim.s" line 500: syntax error as error: "prim.s" line 527: invalid instruction mnemonic (jpl) as error: "prim.s" line 527: syntax error Comments (+Fix?): The intruction "jpl" is not know to the sun2hp translator (in fn do-subst). I don't know what jpl is supposed to do, but my _guess_ is that it should be translated into the branch instruction "bpl.w" (anologious to transl. of jeq, jge, ... etc.). Shouldn't the line (replace-re "\\70Mb swap Severity: minor (but might be major for other people) Problem: A makeml does not succeed (exception raised in Loader) Code: Do a 'makeml -m68 hpux8' with the two fixes to sun2hp.el I send earlier Transcript: >From time to time, I get different results: --- > makeml -m68 hpux8 [...stuff deleted...] signature CLEANUP = ... signature WEAK = ... signature SUSP = ... signature POLY_CONT = ... signature UNSAFE = ... signature SYSTEM = ... [closing boot/system.sig] signature MATH = ... structure Math : MATH [closing boot/math.sml] [Major collection... 20% used (339576/1680172), 250 msec] uncaught exception (Loader): mlyAction --- > makeml -m68 hpux8 [...stuff deleted...] signature LIST = ... signature VECTOR = ... signature ARRAY = ... signature REAL_ARRAY = ... signature BYTEARRAY = ... signature IO = ... signature BOOL = ... signature STRING = ... signature INTEGER = ... signature BITS = ... signature REAL = ... signature GENERAL = ... [closing boot/perv.sig] uncaught exception (Loader): Ord --- > makeml -m68 hpux8 [...stuff deleted...] structure Core : ... [closing boot/dummy.sml] signature REF = ... signature LIST = ... signature VECTOR = ... signature ARRAY = ... signature REAL_ARRAY = ... signature BYTEARRAY = ... signature IO = ... signature BOOL = ... signature STRING = ... signature INTEGER = ... signature BITS = ... signature REAL = ... signature GENERAL = ... [closing boot/perv.sig] uncaught exception (Loader): Ord --- > makeml -m68 hpux8 [...stuff deleted...] signature CLEANUP = ... signature WEAK = ... signature SUSP = ... signature POLY_CONT = ... signature UNSAFE = ... signature SYSTEM = ... [closing boot/system.sig] signature MATH = ... structure Math : MATH [closing boot/math.sml] [Major collection... 20% used (340948/1682456), 333 msec] uncaught exception (Loader): Ord --- Comments: I cannot tell if this phenomenon is caused by the two fixes I made to sun2hp.el: ;; do-subst -- substitute mnemonics, register names, comment symbols etc. ;; (defun do-subst () [...] (replace-re "\\ has moved" old-label) (replace-match (concat new-label ":")))) (setq labels (cdr labels)))) [Reppy:] This bug also occurs on the Sun-3 and NeXT machines. It seems to be a general problem with the M68. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 568 Title: crash on sparc on large compilations Keywords: Submitter: Pierre Cregut Date: 6/5/92 Version: 0.82 System: sparc, SunOS 4.2 Severity: serious Problem: On large compilations (e.g. compiling the compiler) on sparcs that are shared with other large jobs (e.g. lisp or another sml), the compiler will die with a bus error or illegal instruction or something equally drastic. This is fairly consistent. Comments: Can this be avoided by forcing sml to grap a large memory chunk for the heap and hold onto it. Status: obsolete ---------------------------------------------------------------------- Number: 569 Title: failed type inference with flexible records Keywords: Submitter: jont@uk.co.harlqn Date: 6/5/92 Version: SML of NJ version number 0.75 System: Sun 4/330 SunOS 4.1.1 Severity: major Problem: Failed type inference with flexible records Code: fun f x = let val y = #1 x val z = #2 x in (y, z, x:('a * 'b)) end; Transcript: - fun f x = let val y = #1 x val z = #2 x in (y, z, x:('a * 'b)) end; fun f x = let val y = #1 x val z = #2 x in (y, z, x:('a * 'b)) end; val f = fn : 'a * 'b -> 'a * 'c * ('a * 'b) - f(1,0); val it = (1,-,(1,0)) : int * 'a * (int * int) - Comments: The type should be 'a * 'b * ('a * 'b) Fix: Better unification I suspect! Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 570 Title: flexrecord equality types Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 6/8/92 Version: 0.82 System: RISC O/S, MIPS (?) Severity: minor Problem: Flexrecords are always assumed to contain non-equality types when this need not be so. This leads to legal programs being rejected. Code: Consider the following code: fun force_record {x=x, y=y} = 3; fun force_eq x = (x = x); Then, the following function types ok since we close the flexrecord before requiring equality: fun bar (r as {x=x, ...}) = (force_record r; force_eq r); But the following function fails with a "equality type required" error because we attempt to require that the open flexrecord be an equality type: fun foo (r as {x=x, ...}) = (force_eq r; force_record r); Transcript: - use "bug.sml"; (* same code as above *) val force_record = fn : {x:'a,y:'b} -> int val force_eq = fn : ''a -> bool val bar = fn : {x:''a,y:''b} -> bool bug.sml:7.29-7.56 Error: operator and operand don't agree (equality type required) operator domain: ''Z operand: {x:'Y,...} in expression: force_eq r [closing bug.sml] Comments: This problem is due to incorrect code in the type-handling part of the SML/NJ compiler. Fixing this will require changing the definition of types so that flexrecords carry a boolean telling if they are required to have only equality types or not. Unify then needs to be updated to use this information in the proper way. Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 571 Title: no occurs check when instantiating flexrecords Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 6/8/92 Version: 0.82 System: RISC O/S, MIPS (?) Severity: minor Problem: When flexrecords are instantiated (additional fields added/closed), no occurs check is done. The failure to do this can result in cyclic types and hanging the type checker. Code: The following code hangs the typechecker: fun foo {x=x, y=y, z=(z as {...})} = foo z; Transcript: - fun foo {x=x, y=y, z=(z as {...})} = foo z; [hangs here, using more and more space forever] Comments: The problem is in the unify routine. It needs to do an occurs check whenever it instantiates a flex record. Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 572 Title: unify doesn't update depth for flex record types Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 6/8/92 Version: 0.82 System: RISC O/S, MIPS (?) Severity: major (* can result in unsoundness *) Problem: The unify routine in the SML/NJ compiler fails to update the depth fields of variables when dealing with flex records. This causes the type checker to generalize types that should not be generalized. Code: Many examples are possible. The simplest I can think of is: fun snd {a,b} = b; fun f (x as {a,...}) = let val u = snd x in u end; Here, snd has type {a:'a,b:'b} -> 'b and acts to extract the b field of an a-b record. So, we start out defining function f. The (x as {a,...}) in the argument list causes x to be bound to the type {a: 'a#1, ...}. [#i means the variable has depth i. I am assuming for this discussion that depths start with 1 and go up 1 for each lambda level.] Now, in the let val u = snd x, we have to unify the type of x with the argument type of snd, namely {a:'c,b:'b}. This results in x being bound to type {a:'a#1, b:'b#2}. Note the error here. Type 'b should have depth 1 not 2 since it is bound at the 1st lambda level (by variable x). However, due to incorrect code in the unifier, this doesn't happen and 'b has type 2. Thus, when we finish typing the function body we get the type 'b#2, which the depth indicates can be safely generalized. Thus, the function body has polymorphic type 'c. This results in f getting type {a:'a, b:'b} -> 'c when it should have the type {a:'a, b:'b} -> 'b. Transcript: - fun snd {a,b} = b; val snd = fn : {a:'a,b:'b} -> 'b - fun f (x as {a,...}) = let val u = snd x in u end; val f = fn : {a:'a,b:'b} -> 'c - f {a=0, b=true}; val it = - : 'a Comments: The problem is in the handling of types by the SML/NJ compiler. Flexrecords need to have a depth associated with them just like normal variables. This is so that you can unify {a:'a#1, ...#1} with {a:'c#3, b:'d#3} and get {a:'a#1, b:'d#1} not {a:'a#1, b:'d#3}. (Note the depth associated with the dots in that example. This is the critical information missing from the current type representation.) Related-bugs: Bug reports #521 from Mark Leone, #533 from Richard O'Neill, and #569 from jont@uk.co.harlqn are all just (less clear) instances of this bug. Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 573 Title: unifier detects spurious cycles with type abbrevs Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 6/9/92 Version: 0.82 System: RISC O/S, MIPS (?) Severity: minor Problem: The unifier's occurs check sometimes detects a spurious cycle when a type variable is unified with a type abbreviation that stands for that type variable. Code: type 'a ID = 'a; fun f (x:'a) = (x:'a ID); fun g x = g (f x); Transcript: - type 'a ID = 'a; type 'a ID = 'a - fun f (x:'a) = (x:'a ID); val f = fn : 'a -> 'a ID - fun g x = g (f x); std_in:4.1-4.17 Error: pattern and expression in val rec dec don't agree (circularity) pattern: 'Z ID -> 'Y expression: 'Z -> 'Y in declaration: g = (fn x => g ()) [The above is an incorrect error because 'Z ID = 'Z and hence the two types should unify without problems.] Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 574 Title: redundant patterns in compiler Keywords: Submitter: John Reppy Date: 6/12/92 Version: 0.83 Severity: minor Problem: The compiler reports the following redundant patterns in 0.83: modules/sigmatch.sml:0.0 Warning: redundant patterns in match (DATACON {name=n1,rep=r1,...},DATACON {rep=r2,...}) => ... --> _ => ... absyn/printabsyn.sml:0.0 Warning: redundant patterns in match FCTB {def=FCTfct {def=def,param=STRvar ,...},fctvar=FCTvar {access=access,name=fname,...}} => ... FCTB {def=VARfct {def=FCTvar ,...},fctvar=FCTvar {access=access,name=fname,...}} => ... --> _ => ... Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 575 Title: line numbers in interactive error messages (same as 552) Keywords: Submitter: Tim Freeman Date: 6/14/92 Version: 0.80 System: Sun 4, mach Severity: minor Problem: The line numbers printed for errors on std_in are erratic. Transcript: % /usr/misc/.sml/bin/sml - aoeiaoei; std_in:3.1-3.8 Error: unbound variable or constructor aoeiaoei - aoeiaoei; std_in:0.0-0.0 Error: unbound variable or constructor aoeiaoei - aoeiaoei = ueoaoeuaoeu; std_in:0.0-0.0 Error: unbound variable or constructor aoeiaoei std_in:4.1-4.11 Error: unbound variable or constructor ueoaoeuaoeu - Comments: In my opinion, the line numbers reported for the above errors should all have been 1, except the last one should have been 2. Status: same as 552 ---------------------------------------------------------------------- Number: 576 Title: pattern matching in interpreter broken Keywords: Submitter: slind@research.att.com Date: 6/14/92 Version: 83 System: mips and sparc at least; probably all Severity: major Problem: If System.Control.interp is true, pattern matching is broken. Manifested with list patterns. Transcript: $ sml Standard ML of New Jersey, Version 0.83, June 12, 1992 val it = () : unit - System.Control.interp := true; val it = () : unit - val [_] = [1]; std_in:0.0 Warning: binding not exhaustive _ :: nil = ... uncaught exception Match - System.Control.interp := false; val it = () : unit - val [_] = [1]; std_in:0.0 Warning: binding not exhaustive _ :: nil = ... - ^D $ Comments: There is a bug in the interpreter since version 77 caused by a change in the representation of data constructors. - System.Control.interp:= true; val it = () : unit - val [x] = [1]; std_in:3.1-3.13 Warning: binding not exhaustive x :: nil = ... uncaught exception Match - The reason is that cons is tagged with UNTAGGEDREC 2 and the case UNTAGGEDREC is not treated by the switch. Lal and I have infered that the only thing the switch interpretor had to figure out is whether the constructor is tagged or not. So the only necessary lines to add are: -cregut->diff codegen/interp.sml /usr/local/sml/77/src/codegen/interp.sml 291,296d290 < | f((DATAcon(_,UNTAGGEDREC _),ans)::rest) = < let val rest' = f rest < val ans' = M ans < in fn x => if (U.boxed x) then ans' else rest' x < end < Is it true or do we need something else ? Pierre Status: fixed in 0.86 -------------------------------------------------------------------- Number: 577 Title: use of vectors crashes NeXT Keywords: Submitter: Richard O'Neill Date: 6/18/92 Version: 0.75 System: NeXTstation, OS2.1 and NeXTstation Turbo Color, OS 2.2. Severity: Major. Problem: Extensive use of vectors (and probably arrays) when running on NeXTs causes SML to crash with either "Bus Error", "Segmentation Fault", "Illegal instruction" or "EMT trap". The same code, when run on SPARC based Sun machines does not exhibit the same problem. The code below creates a function called 'bug', which takes an integer argument. The larger the argument, the more likely SML is to crash, values like 10000 create an almost immediate crash, values such as 500 sometimes work and sometimes crash SML. (The code is for example purposes only, I don't actually use code as inefficient as this normally! ;o) Code (stored in file "bug.sml"): open Vector fun update(array,index,value) = let fun copy i = if i = index then value else sub(array,i) val size = length array in if index < size then tabulate (size,copy) else raise Vector.Subscript end fun reverse original = let val size = length original fun rev (current,count) = if count < size then let val count' = count + 1 val current' = update(current, count, sub(original, size-count')) in rev (current', count') end else current in rev (original,0) end fun bug n = reverse (tabulate (n, fn x => x)) Transcript: NeXT-Mach% sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "bug.sml"; [opening bug.sml] open Vector val update = fn : 'a vector * int * 'a -> 'a vector val reverse = fn : 'a vector -> 'a vector val bug = fn : int -> int vector [closing bug.sml] val it = () : unit - bug 500; val it = - : int vector - bug 500; Bus error NeXT-Mach% NeXT-Mach% sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "bug.sml"; [opening bug.sml] open Vector val update = fn : 'a vector * int * 'a -> 'a vector val reverse = fn : 'a vector -> 'a vector val bug = fn : int -> int vector [closing bug.sml] val it = () : unit - bug 5000; EMT trap NeXT-Mach% NeXT-Mach% sml Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "bug.sml"; [opening bug.sml] open Vector val update = fn : 'a vector * int * 'a -> 'a vector val reverse = fn : 'a vector -> 'a vector val bug = fn : int -> int vector [closing bug.sml] val it = () : unit - bug 5000; Bus error Comments: It gives an idea how 'wild' the crash is since the latter two cases in the transcript should be identical, and aren't. I suspect it is some kind of memory allocation bug, but who knows.... Comment: [dbm, 10/29/92] Couldn't reproduce this on a Sun 3 with 0.91. Either the bug is cured or it is NeXT specific. Status: fixed in 0.92 ---------------------------------------------------------------------- Number: 578 Title: chatting (in runtime system) doesn't flush stdout Keywords: Submitter: Mark Leone (mleone@cs.cmu.edu) Date: 6/24/92 Version: 80 System: all Severity: minor Problem: chatting() doesn't flush stdout Code: Transcript: Comments: GC messages (and other diagnostic compiler output) sometimes appear before things that have already been printed to stdout (e.g. when redirecting batch compiler output to a log file). This can make it hard to debug the compiler. Fix: Add "fflush(stdout)" to chatting() in runtime/run.c Status: not a bug (inaccurate report according to awa) ---------------------------------------------------------------------- Number: 579 Title: Lexing an illegal token can lead to infinite loop Keywords: Submitter: Andrew Tolmach (apt@research.att.com) Date: 6/30/92 Version: 0.83 System: MIPS and SPARC Severity: Problem: Lexing an illegal token can lead to infinite loop. Code: Typing an arbitrary control character (such as CTRL/A), followed by return, sends system into an infinite loop. Transcript: - ^A std_in:0.0 Error: illegal token ... (infinite loop) ... Comments: (1) Looping doesn't occur if illegal token is followed by a complete legal phrase, e.g., ^A1; (2) Loop can be interrupted with CTRL/C. (3) Didn't occur in 0.82. Fix: Exception handler in ml.lex.sml uses Reject instead of Internal.Reject when Internal is not open, thus producing a handler for all exceptions. Change Reject to Internal.Reject in lexgen. Status: fixed in 0.84 ---------------------------------------------------------------------- Number: 580 Title: System.Compile, System.Env broken in 0.83 Keywords: Submitter: Emden R. Gansner erg@ulysses.att.com Date: 7/3/92 Version: 0.83 System: Sparc 2, SunOS 4.1 Severity: major Problem: Support for separate compilation is broken Code: fun bug () = let open System.Compile System.Env val staticPerv = staticPart(!pervasiveEnvRef) val ins = open_string "signature T = sig end" val source = makeSource("", 1, ins, false, std_out) val (static, _) = compile(source,staticPerv) in changeLvars static end Transcript: Standard ML of New Jersey, Version 0.83, June 12, 1992 val it = () : unit - use "bug.sml"; val bug = fn : unit -> System.Compile.staticUnit [closing bug.sml] val it = () : unit - bug(); Error: Compiler bug: CompileUnit 2 - Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 581 Title: line numbers in error and warning messages Keywords: Submitter: Andrew Appel Date: 7/3/92 Version: 0.83 Severity: serious Problem: Many of the error and warning messages have line numbers of 0.0. Comments: Something wrong in the use of markabsyn. Status: fixed in 0.88 ---------------------------------------------------------------------- Number: 582 Title: interaction of open declarations and eval_stream Keywords: Submitter: Andrew Tolmach (apt@research.att.com) Date: 7/7/92 Version: 0.83 System: MIPS riscos Severity: minor Problem: If an open declaration is evaluated by System.Compile.eval_stream, the resulting first-class environment is inconsistent: the static environment contains the elements of the opened structure, but the structure itself is not included in the dynamic environment. Subsequent attempts to look up these elements in the first-class environment trigger IntMapF exceptions. Transcript: Standard ML of New Jersey, Version 0.83, June 12, 1992 val it = () : unit - open System.Compile System.Env System.Symbol; open Compile Env Symbol - structure Fred = struct val a = 10 end; structure Fred : sig val a : int end - val e = eval_stream(open_string "open Fred", = layerEnv(!topLevelEnvRef,!pervasiveEnvRef)); open Fred [closing ] val e = prim? : environment - val e' = layerEnv(e,!pervasiveEnvRef); val e' = prim? : environment - eval_stream(open_string "a",e'); [closing ] uncaught exception IntmapF - Fix: (suggested by Tolmach) A top-level open should create a new structure entry in the dynamic environment, and paths for entries in the static environment should be adjusted to point at this new entry. Fix: (implemented in 0.91) A top-level open causes all the runtime components of the structures opened to be rebound in the top-level environment. Status: fixed in 0.91 ---------------------------------------------------------------------- Number: 583 Title: catalogEnv raises Match exception Keywords: Submitter: Andrew Tolmach (apt@research.att.com) Date: 7/7/92 Version: 0.83 System: Mips riscos Severity: minor Problem: Executing System.Env.catalogEnv(staticPart (!pervasiveEnvRef)) provokes a Match exception. Comment: Problem is evidently with modules/moduleutil.sml:sortEnvBindings.binderGt, which contains an incomplete match. Perhaps TAB binding entries need to be included? Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 584 Title: infinite loop in cpsopt Keywords: Submitter: John Reppy (jhr@research.att.com) Date: 7/10/92 Version: 0.84 Severity: major Problem: The following program causes an infinite loop in cpsopt (I assume that this is another case of infinite loop unrolling): Code: fun foo () = let fun loop () = loop () in loop () end; Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 585 Title: wrong type for notb in perv.sig Keywords: Submitter: Nick Haines (Nick_Haines@VOILA.VENARI.CS.CMU.EDU) Date: 7/10/92 Version: 0.84 Severity: minor Problem: In boot/perv.sig, the type of `notb' is given as int * int -> int not as int -> int as it should be (and as boot/perv.sml has it). Fix: change the type in perv.sig Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 586 Title: uncaught Match in interpreter Keywords: Submitter: John Reppy (jhr@research.att.com) Date: 7/10/92 Version: 0.77 and later System: any Severity: minor Problem: an uncaught exception Match in the interpreter Code: System.Control.interp := true; datatype t = Z | S of t; fn (S _) => 0; Transcript: Standard ML of New Jersey, Version 0.77, February 24, 1992 Arrays have changed; see Release Notes val it = () : unit - datatype t = Z | S of t; System.Control.interp := true; fn (S _) => 0; datatype t con S : t -> t con Z : t val it = () : unit std_in:2.57-2.69 Warning: match not exhaustive S _ => ... uncaught exception Match - Comments: Mark Lillibridge tracked this down to codegen/interp.sml; specifically, the function "f" in the case SWITCH(e,_, l as (DATAcon _, _)::_, d) => ... The problem seems to be a result of the changes in the datatype representation. Is this the same as bug #576? Bug # 591 is another instance of this Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 587 Title: Compiler bug: ModuleUtil: Instantiate:getSigPos.2 Keywords: Submitter: Olivier Nora Date: 7/14/92 Version: 0.84 Severity: major Problem: Following code produces compiler bug: ModuleUtil: Instantiate:getSigPos.2 Code: signature SEQUENCE = sig exception LoopingError type 'a sequence val read : '1a sequence -> ('1a * '1a sequence) option val append : '1a list * '1a sequence -> '1a sequence val add_to : '1a sequence -> '1a sequence -> unit val app : ('2a -> '2b) sequence -> '2a sequence -> '2b sequence val value : '1a -> '1a sequence val empty_sequence : unit -> '1a sequence end signature SEMANTIC_VALUE = sig type 'a semantic_type type semantic_value type 'a sequence exception SemanticValueError of string val add_semantic_value : semantic_value -> semantic_value -> unit val cast_from : 'a semantic_type -> semantic_value -> 'a sequence val cast_to : 'a semantic_type -> 'a sequence -> semantic_value val void_semantic_value : semantic_value end funsig MK_SEMANTIC_VALUE (Sequence : SEQUENCE) = SEMANTIC_VALUE functor MkWhole (functor MkSemanticValue : MK_SEMANTIC_VALUE) = struct end Comment: [Cregut] The bug can be obtained by the simple following code: signature A=sig end signature B=sig functor f():A end; and comes from the fact that A is declared before so contains no arguments. The fix is a 3 lines changed in extern.sml that ask the function not to worry if the argument is not there. It should be in .85 Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 588 Title: wrong printing of flex records with no fields Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 7/14/92 Version: 0.83 Severity: minor Problem: The abstract syntax printing routines print out flex records with no fields wrong. I.e., as "{,...}" instead of "{...}". Code: (fn {...} => ()) 3; Transcript: - (fn {...} => ()) 3; std_in:18.1-18.18 Error: operator and operand don't agree (type mismatch) operator domain: {...} operand: int in expression: ((fn {,...} => ())) 3 ^^^^-------------------- note error Comments: same as bug #468 which was mislabeled Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 589 Title: occurs check with nonstrict type abbreviations Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 7/14/92 Version: 0.83 Severity: minor Problem: The occurs check is done wrong in the presense of non-strict type abbreviations. Code: type 'a CON = int; fun foo (x:'a) = (3:'a CON); fun bar x = bar (foo x); Transcript: - type 'a CON = int; type 'a CON = int - fun foo (x:'a) = (3:'a CON); val foo = fn : 'a -> 'a CON - fun bar x = bar (foo x); [type checker hangs at this point] Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 590 Title: Some user type variable names are handled incorrectly. Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 7/14/92 Version: 0.83 Severity: minor Problem: Some user type variable names are handled incorrectly. Code: val x : '_1abcd = 3; Transcript: - val x : '_1abcd = 3; std_in:0.0-0.0 Error: pattern and expression in val dec don't agree (type mismatch) pattern: '1_1abcU expression: int in declaration: x : '1_1abcU = 3 ^^^^------------------- note no 'd' on end! Comment: Note that this kind of type variable name is no longer legal as of 0.85. Status: fixed in 0.85 ---------------------------------------------------------------------- Number: 591 Title: uncaught Match evaluating fn expressions. Keywords: Submitter: Elsa Gunter Date: 7/15/92 Version: 0.84 Severity: major Problem: Match exception raised when evaluating innocuous "fn" expressions. This was in a version of 0.84 in which eXene was loaded. Transcript: - fn (th :: _) => [th] | nil => nil; uncaught exception Match - fn (SOME x) => [x] = | NONE => []; uncaught exception Match Comment: does not occur in plain 0.84 Confirmed to be an instance of bug #586 Status: fixed in 0.86 ---------------------------------------------------------------------- Number: 592 Title: unhelpful error messages for record type mismatches Keywords: Submitter: thomas yan, tyan@cs.cornell.edu Date: 7/17/92 Version: <= .85 Severity: minor, but annoying Problem: unhelpful error messages for record type mismatches Code: val {e:int, g:int, i:int, k:int option, m:int, p:int, ...} = {e=0, g=0, j=0, k=[0], n=0, p=0, r=0, t=0, w=0, x=0, z=0} (* and similar variations *) Transcript: - val {e:int, g:int, i:int, k:int option, m:int, p:int, ...} = {e=0, g=0, j=0, k=[0], n=0, p=0, r=0, t=0, w=0, x=0, z=0}; std_in:0.0-331.117 Error: pattern and expression in val dec don't agree (record labels) pattern: {e:int,g:int,i:int,k:int option,m:int,p:int,...} expression: {e:int,g:int,j:int,k:int list,n:int,p:int,r:int,t:int,w:int,x:int,z:int} in declaration: {e=e : int,g=g : int,i=i : int,k=k : int option,m=m : int,p=p : int,...} = {e=0,g=0,j=0,k=0 :: nil,n=0,p=0,r=0,t=0,w=0,x=0,z=0} - val {e:int, g:int, i:int, k:int option, m:int, p:int} = {e=0, g=0, j=0, k=[0], n=0, p=0}; std_in:0.0-331.87 Error: pattern and expression in val dec don't agree (tycon mismatch) pattern: {e:int,g:int,i:int,k:int option,m:int,p:int} expression: {e:int,g:int,j:int,k:int list,n:int,p:int} in declaration: {e=e : int,g=g : int,i=i : int,k=k : int option,m=m : int,p=p : int} = {e=0,g=0,j=0,k=0 :: nil,n=0,p=0} Comments: the error messages should indicate which labels are a) ok, b) extra/mispelled, c) missing. also, (and this is a problem in general with type error messages), the field type mismatches should be highlighted, as just "tycon mismatch" gives one no idea where the mismatch is. Fix: use some kind of field by field comparison of the pattern and expression (a 2-column format, while verbose, might work well), perhaps first listing all fields that match, then listing all labels with mismatched types, then extra labels in the expression, then (possibly even for flex records) omitted labels. Owner: Status: open ---------------------------------------------------------------------- Number: 593 Title: Compiler bug from bad overload declaration Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 7/17/92 Version: 0.83 System: Sparc Severity: minor Problem: When values supplied in an overload declaration fail to meet the spec given, a compiler bug sometimes occurs. Code: fun baz [x] = x + 1; overload quux : ('a -> 'a) as tl and baz; Transcript: - fun baz [x] = x + 1; std_in:0.0 Warning: match not exhaustive x :: nil => ... val baz = fn : int list -> int - overload quux : ('a -> 'a) as tl and baz; Error: Compiler bug: matchScheme: bad tyvar 0 Status: fixed in 0.93c ---------------------------------------------------------------------- Number: 594 Title: "val _ = =;" now giving a different (wrong) error (same as 549) Keywords: Submitter: Mark Lillibridge (mdl@cs.cmu.edu) Date: 7/17/92 Version: 0.83 System: Sparc Severity: minor Problem: "val _ = =;" now giving a different (wrong) error Code: val _ = =; Transcript: - val _ = =; std_in:7.9 Error: nonfix identifier required Error: Compiler bug: elabVB Comment: This bug report is an addeneum to bug report #549. That bug reported that a non-handled Match exception occured on this program. This bug report is to report that that no longer happens in 0.83. Instead, a "elabVB" compiler bug occurs. Still a bug though. Status: same as 549 ---------------------------------------------------------------------- Number: 595 Title: uncaught exception UnboundTable compiling bogus signature Keywords: Submitter: John Reppy Date: 7/22/92 Version: 0.85 System: Sun 4/75 Severity: minor Problem: uncaught exception UnboundTable in compiler Code: signature JGRAPH = sig structure IO end functor JGraph (IO : IO) : JGRAPH = struct end Transcript: Standard ML of New Jersey, Version 0.85, July 17, 1992 val it = () : unit - use "bug.sml"; bug.sml:3.5-3.13 Error: syntax error: replacing STRUCTURE with EQTYPE bug.sml:1.1-8.5 Error: unmatched type spec: IO [closing bug.sml] uncaught exception UnboundTable - Comments: If you type the code into the top-level loop, you get a different kind of syntax error, and the bug doesn't occur. Status: fixed in 0.89 ---------------------------------------------------------------------- Number: 596 Title: bad line number info in error messages Keywords: Submitter: Andrew Appel Date: 7/24/92 Version: 0.86 Severity: major Problem: Many error messages say line "0.0-0.0". Status: fixed in 0.88 ---------------------------------------------------------------------- Number: 597 Title: Compiler bug: errors in cps/generic/extract Keywords: Submitter: Magnus Carlsson Date: 7/26/92 Version: 0.75 System: Sun-4 Severity: major Problem: Following code causes Compiler bug: errors in cps/generic/extract. Code: datatype 'a fcont = Fcont of 'a fcont cont | Thrown of 'a; case callcc Fcont of Fcont k => throw k (Thrown 5) | Thrown i => i; Transcript: animal> smlc Standard ML of New Jersey, Version 75, November 11, 1991 Arrays have changed; see Release Notes val it = () : unit - use "callcc-error.ml"; [opening callcc-error.ml] datatype 'a fcont con Fcont : 'a fcont cont -> 'a fcont con Thrown : 'a -> 'a fcont Error: Compiler bug: errors in cps/generic/extract [closing callcc-error.ml] - Status: fixed in 0.89 ---------------------------------------------------------------------- Number: 598 Title: Compiler bug: applyTyfun: not enough arguments Keywords: Submitter: Andrew Appel Date: 7/27/92 Version: 0.86 Severity: minor Problem: Compiler bug after incorrect datatype/withtype declaration. Code: datatype 'a t = A of u withtype 'a u = 'a list Transcript: foo.sml:0.0 Error: type constructor u has the wrong number of arguments: 0 Error: Compiler bug: applyTyfun: not enough arguments Comment: [mdl] Turned out to be another bug in the module system where a bad tycon was returned in spite of an error being detected. Fix is to change so that ERRORtyc is returned on error. The diffs to fix it follow. I tested the change on the 86 sources and it seems to work fine. Fix: diff moduleutil.sml.86 moduleutil.sml: ------------------ cut here ------------------ 524c524 < fun checkArity(tycon, arity,err) = --- > fun checkArity(tycon, arity,err,result) = 526c526 < of ERRORtyc => () --- > of ERRORtyc => result 529,531c529,532 < then err COMPLAIN ("type constructor "^(Symbol.name(tycName(tycon)))^ < " has the wrong number of arguments: "^makestring arity) < else () --- > then (err COMPLAIN ("type constructor "^(Symbol.name(tycName(tycon)))^ > " has the wrong number of arguments: "^makestring arity); > ERRORtyc) > else result 537,538c538,539 < (checkArity(spec,arity,err); < RELtyc{name=name,pos=(relpos,pos)}) --- > checkArity(spec,arity,err, > RELtyc{name=name,pos=(relpos,pos)}) 540,541c541,542 < (checkArity(spec,arity,err); < RELtyc{name=name,pos=pos}) --- > checkArity(spec,arity,err, > RELtyc{name=name,pos=pos}) 544c545 < | (TYCbind tyc,_,_) => (checkArity(tyc,arity,err); tyc) --- > | (TYCbind tyc,_,_) => checkArity(tyc,arity,err,tyc) Status: fixed in 0.88 ---------------------------------------------------------------------- Number: 599 Title: symbolic path names are reversed in error messages. Keywords: Submitter: Andrew Appel Date: 7/27/92 Version: 0.86 Severity: minor Problem: Symbolic path names are reversed in error messages. What should be "MipsInstrSet.instruction", is instruction.MipsInstrSet (etc.) Transcript: mips/mips.sml:0.0 Error: Inconsistent arities in sharing type instruction.MipsIn strSet = instruction.C. : instruction.MipsInstrSet has arity 1 and in struction.C. has arity 0. mips/mips.sml:0.0 Error: Inconsistent arities in sharing type sdi.MipsInstrSet = sdi.C. : sdi.MipsInstrSet has arity 1 and sdi.C. has arit Status: fixed in 0.89 ---------------------------------------------------------------------- Number: 600 Title: Core dump running sourcegroup 2.1 Keywords: Submitter: Amy Felty Date: 7/28/92 Version: 0.86 System: Sparc, SunOS 4.1 Severity: major Problem: Core dump running sourcegroup 2.1 Code: SMLTool.targetNamer := SourceAction.sysBinary; System.Control.Print.signatures := 0; System.Control.indexing := true; structure SG = SourceGroup; structure SA = SourceAction; structure FL = FileList; fun smlFiles dirs = FL.extensionsOnly ["fun", "sig", "sml"] (FL.inDir (false, dirs)); fun mlyaccFiles dirs = FL.extensionsOnly ["lex", "grm"] (FL.inDir (false, dirs)); val mlyaccGroup = SG.create [SG.Sources (FL.inFile ["mlyacc/base/base.files"])]; Transcript: - lutece:working> sml-sg Standard ML of New Jersey, Version 0.86, July 22, 1992 with SourceGroup 2.1 built on Fri Jul 24 10:48:49 EDT 1992 val it = () : unit - use "build-elp.sml"; val it = () : unit val it = () : unit val it = () : unit structure SG : SOURCEGROUP structure SA : SOURCEACTION structure FL : FILELIST val smlFiles = fn : string list -> string list val mlyaccFiles = fn : string list -> string list Segmentation fault lutece:working> Status: fixed in 0.87 ----------------------------------------------------------------------