diff --git a/src/basis.mlp b/src/basis.mlp index a42893ac..357e934d 100755 --- a/src/basis.mlp +++ b/src/basis.mlp @@ -282,8 +282,8 @@ basis.mlp 306 7 win_nt/windows.sml I386/Linux 18 1 Library 0 0 - win_nt/__os_exit.sml - win_nt/os_exit.sml + unix/__os_exit.sml + unix/os_exit.sml unix/platform_specific_exports.sml unix/__os.sml unix/__os_file_sys.sml diff --git a/src/basis/__char_array.sml b/src/basis/__char_array.sml index 0505b91f..78f06f1b 100644 --- a/src/basis/__char_array.sml +++ b/src/basis/__char_array.sml @@ -117,9 +117,10 @@ structure CharArray : MONO_ARRAY = (ignore(check_size (length l)); A (MLWorks.Internal.ByteArray.arrayoflist (cast l))) - val length : array -> int = cast(MLWorks.Internal.ByteArray.length) - val sub : (array * int) -> elem = cast(MLWorks.Internal.ByteArray.sub) - val update : (array * int * elem) -> unit = cast(MLWorks.Internal.ByteArray.update) + fun length (A ba) : int = MLWorks.Internal.ByteArray.length ba + fun sub (A ba, i:int) : elem = cast(MLWorks.Internal.ByteArray.sub (ba, i)) + fun update (A ba, i:int, x:elem) : unit = + MLWorks.Internal.ByteArray.update (ba, i, cast x) val extract : (array * int * int option ) -> vector = fn (A a,i,len) => @@ -130,7 +131,7 @@ structure CharArray : MONO_ARRAY = | NONE => MLWorks.Internal.ByteArray.length a - i in if i >= 0 andalso len >= 0 andalso i + len <= MLWorks.Internal.ByteArray.length a - then cast(MLWorks.Internal.ByteArray.substring (a,i,len)) + then MLWorks.Internal.ByteArray.substring (a,i,len) else raise Subscript end diff --git a/src/basis/__timer.sml b/src/basis/__timer.sml index 872ef906..17659539 100644 --- a/src/basis/__timer.sml +++ b/src/basis/__timer.sml @@ -113,7 +113,7 @@ structure Timer : TIMER = fun totalRealTimer() = TOTAL - val startTime = env "Time.start" + val startTime : unit -> Time.time = env "Time.start" fun checkRealTimer arg = let diff --git a/src/basis/__word8_array.sml b/src/basis/__word8_array.sml index 61cbe502..34156418 100644 --- a/src/basis/__word8_array.sml +++ b/src/basis/__word8_array.sml @@ -101,20 +101,24 @@ structure Word8Array : MONO_ARRAY = fun check_size n = if n < 0 orelse n > maxLen then raise Size else n + val cast = MLWorks.Internal.Value.cast + fun array (i: int, e: elem) : array = - A (MLWorks.Internal.ByteArray.array (check_size i, MLWorks.Internal.Value.cast e)) + A (MLWorks.Internal.ByteArray.array (check_size i, cast e)) fun tabulate (i : int, f : int -> elem) : array = - A (MLWorks.Internal.ByteArray.tabulate (check_size i,MLWorks.Internal.Value.cast f)) + A (MLWorks.Internal.ByteArray.tabulate (check_size i,cast f)) (* uses toplevel List.length which is overridden afterwords *) fun fromList (l : elem list) : array = (ignore(check_size (length l)); - A (MLWorks.Internal.ByteArray.arrayoflist (MLWorks.Internal.Value.cast l))) + A (MLWorks.Internal.ByteArray.arrayoflist (cast l))) + - val length : array -> int = MLWorks.Internal.Value.cast(MLWorks.Internal.ByteArray.length) - val sub : (array * int) -> elem = MLWorks.Internal.Value.cast(MLWorks.Internal.ByteArray.sub) - val update : (array * int * elem) -> unit = MLWorks.Internal.Value.cast(MLWorks.Internal.ByteArray.update) + fun length (A ba) : int = MLWorks.Internal.ByteArray.length ba + fun sub (A ba, i:int) : elem = cast(MLWorks.Internal.ByteArray.sub (ba, i)) + fun update (A ba, i:int, x:elem) : unit = + MLWorks.Internal.ByteArray.update (ba, i, cast x) val extract : (array * int * int option ) -> vector = fn (A a,i,len) => @@ -125,7 +129,7 @@ structure Word8Array : MONO_ARRAY = | NONE => MLWorks.Internal.ByteArray.length a - i in if i >= 0 andalso len >= 0 andalso i + len <= MLWorks.Internal.ByteArray.length a - then MLWorks.Internal.Value.cast(MLWorks.Internal.ByteArray.substring (a,i,len)) + then cast (MLWorks.Internal.ByteArray.substring (a,i,len)) else raise Subscript end diff --git a/src/basis/_stream_io.sml b/src/basis/_stream_io.sml index c1b2960f..74bba567 100644 --- a/src/basis/_stream_io.sml +++ b/src/basis/_stream_io.sml @@ -497,7 +497,7 @@ functor StreamIO(structure PrimIO : PRIM_IO } - val openStreams = ref [] + val openStreams = ref ([]:outstream list) fun addOpenStream (s as Out{name,...}) = (openStreams := s :: !openStreams; s) @@ -511,7 +511,8 @@ functor StreamIO(structure PrimIO : PRIM_IO fun handler(Out{name,...},function, cause) = raise IO.Io{name=name,function=function,cause=cause} - val exit_function_key = ref NONE (* Handle to exit function if installed *) + (* Handle to exit function if installed *) + val exit_function_key = ref (NONE:MLWorks.Internal.Exit.key option) fun mkOutstream(w, mode) = let val s = @@ -657,7 +658,9 @@ functor StreamIO(structure PrimIO : PRIM_IO val blen = Array.length data val p = !pos fun copy offset = - (Array.copyVec {src=s, si=0, len=SOME slen, dst=data, di=offset}; + ((if slen = 0 then () + else Array.copyVec {src=s, si=0, len=SOME slen, + dst=data, di=offset}); pos := offset + slen) in if p+slen < blen then copy p diff --git a/src/batch.mlp b/src/batch.mlp index 7947b023..f126cc0c 100755 --- a/src/batch.mlp +++ b/src/batch.mlp @@ -28,7 +28,7 @@ batch.mlp 661 7 main/link_support.sml main/object_output.sml rts/gen/__implicit.sml - rts/gen/__objectfile.sml + main/__objectfile.sml rts/gen/__tags.sml rts/gen/implicit.sml rts/gen/objectfile.sml diff --git a/src/lambda/_lambda.sml b/src/lambda/_lambda.sml index f9e7d14e..51f53a5d 100644 --- a/src/lambda/_lambda.sml +++ b/src/lambda/_lambda.sml @@ -888,13 +888,13 @@ struct val dummy_var = new_LVar() val dummy_varexp = LambdaTypes.VAR dummy_var - val env_reduce = - Lists.reducel - (fn (env, (env', _, _)) => Environ.augment_env(env, env')) + fun env_reduce (init, list) = + Lists.reducel (fn (env, (env', _, _)) => Environ.augment_env(env, env')) + (init, list) - val denv_reduce = - Lists.reducel - (fn (env, (_, env',_)) => Environ.augment_denv(env, env')) + fun denv_reduce (init, list) = + Lists.reducel (fn (env, (_, env',_)) => Environ.augment_denv(env, env')) + (init, list) fun env_from_list env_le_list = env_reduce(Environ.empty_env, env_le_list) diff --git a/src/lambda/_lambdaflow.sml b/src/lambda/_lambdaflow.sml index 7b8dd3e6..23ca1097 100644 --- a/src/lambda/_lambdaflow.sml +++ b/src/lambda/_lambdaflow.sml @@ -75,7 +75,12 @@ functor LambdaFlow (structure SimpleUtils : SIMPLEUTILS structure RuntimeEnv : RUNTIMEENV structure MachSpec : MACHSPEC + (* D: FIXME: apparently a SMLNJ bug that prevents + this Compilation continues without it, tho. + Not sure if it causes problems later. sharing LambdaPrint.LambdaTypes = SimpleUtils.LambdaTypes + *) + sharing type SimpleUtils.LambdaTypes.FunInfo = RuntimeEnv.FunInfo ) : LAMBDAFLOW = diff --git a/src/main/__encapsulate.sml b/src/main/__encapsulate.sml index df77e1b4..74b5ec41 100644 --- a/src/main/__encapsulate.sml +++ b/src/main/__encapsulate.sml @@ -154,8 +154,8 @@ require "../lambda/__environtypes"; require "../main/__pervasives"; require "../main/__info"; require "../main/__code_module"; -require "../rts/gen/__objectfile"; require "../debugger/__debugger_types"; +require "__objectfile"; require "__enc_sub"; require "_encapsulate"; diff --git a/src/main/__objectfile.sml b/src/main/__objectfile.sml new file mode 100644 index 00000000..b4af1c38 --- /dev/null +++ b/src/main/__objectfile.sml @@ -0,0 +1,20 @@ +(* __objectfile.sml the structure *) +(* + * Object file opcodes + * Originally generated from rts/src/objectfile.h, but copied + * here to represent the output of the current compiler source, + * which is *not* necessarily what the runtime system can load. + * + * Copyright 2013 Ravenbrook Limited + *) + +structure ObjectFile_ = +struct + val GOOD_MAGIC = 450783256 + val HEADER_SIZE = 36 + val OBJECT_FILE_VERSION = 20 + val OPCODE_CODESET = 0 + val OPCODE_REAL = 1 + val OPCODE_STRING = 2 + val OPCODE_EXTERNAL = 3 +end; diff --git a/src/main/_project.sml b/src/main/_project.sml index 3cf0bbb1..b154f26f 100644 --- a/src/main/_project.sml +++ b/src/main/_project.sml @@ -1073,7 +1073,7 @@ struct fun mark_visited (v, m) = NewMap.define (v, m, false) fun mark_compiled (v, m) = NewMap.define (v, m, true) - val empty_map = NewMap.empty (ModuleId.lt, ModuleId.eq) + val empty_map : StatusMap = NewMap.empty (ModuleId.lt, ModuleId.eq) val visited_pervasives = mark_compiled (empty_map, Io.pervasive_library_id) fun no_targets (error_info, location) projectName = diff --git a/src/main/_toplevel.sml b/src/main/_toplevel.sml index 188e82c6..adab75af 100644 --- a/src/main/_toplevel.sml +++ b/src/main/_toplevel.sml @@ -1167,7 +1167,8 @@ struct val empty_env = CB(Parser.empty_pB, Basis.empty_basis, Environ.empty_top_env) - val empty_string_map = NewMap.empty (op < : string * string -> bool, op =) + val empty_string_map : (string, (string * int * int)) NewMap.map = + NewMap.empty (op < : string * string -> bool, op =) val empty_debug_info = Debugger_Types.empty_information diff --git a/src/make/change_nj.sml b/src/make/change_nj.sml new file mode 100644 index 00000000..3626d7ba --- /dev/null +++ b/src/make/change_nj.sml @@ -0,0 +1,1547 @@ +(* ==== MODIFY NEW JERSEY ENVIRONMENT ==== + * + * Copyright (C) 1993 Harlequin Ltd + * + * Description + * ----------- + * This New Jersey ML source simulates the MLWorks pervasive environment + * under New Jersey, to the extent that we are able to compile the + * compiler. + * + * Revision Log + * ------------ + * $Log: change_nj.sml,v $ + * Revision 1.113 1996/04/18 09:15:09 stephenb + * Remove exit, terminate, atExit and most of the OS structure since + * they are no longer needed now that OS.Process has been updated. + * + * Revision 1.112 1996/03/28 10:08:24 matthew + * Adding definition of outstream + * + * Revision 1.111 1996/03/08 12:04:29 daveb + * Converted the types Dynamic and Type to the new identifier naming scheme. + * + * Revision 1.110 1996/02/22 14:54:37 daveb + * Moved MLWorks.Dynamic to MLWorks.Internal.Dynamic. Hid some members; moved + * some functionality to the Shell structure. + * + * Revision 1.109 1996/02/16 15:38:29 nickb + * name change fn_save => deliver + * + * Revision 1.108 1996/01/23 10:32:07 matthew + * Adding nj-env.sml file + * + * Revision 1.107 1996/01/22 08:34:29 stephenb + * OS reorganisation: Remove the OS specific stuff since + * this is no longer in the pervasive library. + * + * Revision 1.106 1996/01/16 12:15:33 nickb + * Change to GC interface. + * + * Revision 1.105 1996/01/15 16:24:18 matthew + * Adding NT directory operations + * + * Revision 1.104 1996/01/15 11:49:46 nickb + * Add thread sleep and wake operations. + * + * Revision 1.103 1996/01/15 09:28:31 stephenb + * Update wrt change in ../pervasive/__pervasive_library.sml + * + * Revision 1.102 1996/01/08 14:28:48 nickb + * Signal reservation removed. + * + * Revision 1.101 1995/12/04 15:46:54 daveb + * Pervasive module names now begin with a space. + * + * Revision 1.100 1995/11/21 11:23:35 jont + * Add Frame.frame_double for accessing directly spilled reals + * + * Revision 1.99 1995/10/17 12:53:35 jont + * Add exec_save for saving executables + * + * Revision 1.98 1995/09/18 09:52:54 daveb + * COrrected syntax error. + * + * Revision 1.97 1995/09/18 09:12:57 daveb + * Made quot and rem be nonfix. + * + * Revision 1.96 1995/09/13 14:26:22 jont + * Add fn_save + * + * Revision 1.95 1995/09/13 13:44:00 daveb + * Removed bogus path name that I was using to test previous changes. + * + * Revision 1.94 1995/09/13 13:08:39 daveb + * Implemented overloaded types for different sizes of words and ints. + * + * Revision 1.93 1995/08/10 15:42:01 jont + * Add ml_char for giving textual representation of chars + * + * Revision 1.92 1995/07/28 08:31:40 matthew + * Adding makestring function to Word structure + * + * Revision 1.91 1995/07/25 14:01:17 jont + * Add Word structure and Overflow exn + * + * Revision 1.90 1995/07/24 10:06:29 jont + * Add Overflow to structure exception + * + * Revision 1.89 1995/07/19 15:10:31 nickb + * Two constructors called MLWorks.Profile.Profile. + * + * Revision 1.88 1995/07/19 13:53:24 nickb + * Whoops; major type screwups in new profiler. + * + * Revision 1.87 1995/07/19 13:40:57 nickb + * Change to profiler interface. + * + * Revision 1.86 1995/07/19 09:15:59 jont + * Add chars stuff + * Also add new integer functions for hex printing + * + * Revision 1.85 1995/06/02 13:59:54 nickb + * Change threads restart system. + * + * Revision 1.84 1995/05/23 15:43:53 nickb + * Add threads system. + * + * Revision 1.83 1995/05/11 09:35:56 jont + * Bring up to date with revised basis stuff in __pervasive_library.sml + * + * Revision 1.82 1995/05/02 13:13:11 matthew + * Adding CAST and UMAP primitives + * Removing some stuff from Debugger + * + * Revision 1.81 1995/04/18 09:06:55 jont + * Add missing values atExit and terminate + * + * Revision 1.80 1995/03/20 10:41:00 matthew + * Adding implode_char + * + * Revision 1.79 1995/03/02 13:41:07 matthew + * Unifying Value.Frame and Frame.pointer + * + * Revision 1.78 1995/01/16 10:16:10 jont + * Bring into line with current state of Win_nt structure (getcd and get_path_name) + * + * Revision 1.77 1994/12/09 14:39:46 jont + * Add OS.Win_nt structure + * + * Revision 1.76 1994/11/24 16:13:54 matthew + * Adding new unsafe operations in MLWorks.Internal.Value + * + * Revision 1.75 1994/09/27 16:05:01 matthew + * Added pervasive Option structure + * + * Revision 1.74 1994/08/25 09:12:36 matthew + * Adding unsafe array operations + * + * Revision 1.73 1994/07/08 10:13:32 nickh + * Add event functions for stack overflow and interrupt handlers. + * + * Revision 1.72 1994/07/01 14:58:51 jont + * Add messages to Io + * + * Revision 1.71 1994/06/24 09:01:44 nickh + * Add trace.restore_all + * + * Revision 1.70 1994/06/10 10:03:18 nosa + * Breakpoint settings on function exits. + * + * Revision 1.69 1994/06/09 15:40:59 nickh + * Updated runtime system handling. + * + * Revision 1.68 1994/04/08 08:04:49 daveb + * Updated with set_file_modified and associated type. + * + * Revision 1.67 1994/03/24 16:16:24 daveb + * Adding handler around realpath. + * + * Revision 1.66 1994/03/24 10:41:48 daveb + * Fixing typo (braino?). + * + * Revision 1.65 1994/03/23 17:35:08 daveb + * Added realpath to NJ runtime. + * + * Revision 1.64 1994/03/14 17:37:26 nickh + * Add an fsync when closing files. + * + * Revision 1.63 1994/03/01 10:08:05 nosa + * option was missing in structure Debugger. + * + * Revision 1.62 1994/02/27 22:01:08 nosa + * Step and breakpoints Debugger. + * + * Revision 1.61 1994/02/08 17:27:42 nickh + * Hope it works now :-) + * + * Revision 1.60 1994/02/08 14:26:08 matthew + * Added definition for realpath. This is just the identity function. + * + * Revision 1.59 1994/02/08 10:51:34 nickh + * Added MLWorks.String.ml_string + * + * Revision 1.58 1994/02/03 09:47:49 matthew + * Added definition for getwd + * + * Revision 1.57 1993/11/26 12:31:52 nickh + * Hacks for Elapsed.elapsed, elapsed_since, format. + * + * Revision 1.56 1993/11/22 16:26:36 jont + * Changed type of modules to include a time stamp field + * + * Revision 1.55 1993/11/18 12:16:15 nickh + * Add to IO and RawIO to provide closed_in and closed_out functions for + * testing open/closed status. (also fix Time structure bug). + * + * Revision 1.54 1993/11/15 15:18:52 nickh + * New pervasive time structure; in particular extension to encode/decode. + * + * Revision 1.53 1993/08/31 09:52:13 daveb + * Added OS.Unix.{unlink,rmdir,mkdir} + * + * Revision 1.52 1993/08/26 11:13:21 richard + * Removed the X exception. It's now in the Motif interface code. + * + * Revision 1.51 1993/08/26 10:09:04 richard + * Declared a special version of require for the pervasive modules. This + * is necessary because of changes to the module naming scheme. + * + * Revision 1.50 1993/08/26 09:58:26 richard + * Added X exception. + * + * Revision 1.49 1993/08/25 14:01:00 richard + * Added dummy MLWorks.OS.Unix.kill. + * + * Revision 1.48 1993/07/28 11:35:56 richard + * Changes to MLWORKS signature. See pervasive/mlworks.sml. + * + * Revision 1.47 1993/07/19 13:37:03 nosa + * Added two frame functions for debugger + * + * Revision 1.46 1993/06/10 15:58:25 matthew + * Added text_preprocess hook + * + * Revision 1.45 1993/05/05 16:05:56 jont + * Added MLWorks.OS.Unix.password_file to get the association list of user names + * to home directories necessary for translating ~ + * + * Revision 1.44 1993/04/23 14:51:13 jont + * Added Integer and Real substructures of MLWorks + * + * Revision 1.43 1993/04/22 17:22:21 jont + * Added write_byte for FileIO and output_byte to RawIO + * + * Revision 1.42 1993/04/22 13:39:46 richard + * Removed defunct Editor interface and added sytem calls to enable + * its replacement. + * + * Revision 1.41 1993/04/20 10:12:57 richard + * New Unix and Trace stuff. See MLWorks signature. + * + * Revision 1.40 1993/04/13 09:59:17 matthew + * Changed TypeRep to Dynamic and restructured + * Moved break stuff out of tracing. + * + * Revision 1.39 1993/04/08 17:29:56 jont + * Minor modifications to editor structure + * + * Revision 1.38 1993/04/06 13:00:31 jont + * Removed use of pervasive ordof + * + * Revision 1.37 1993/04/02 15:27:40 jont + * Extended images structure to include table of contents reading + * + * Revision 1.36 1993/03/26 15:53:27 matthew + * Added break function to Tracing substructure + * + * Revision 1.35 1993/03/23 18:32:34 jont + * Minor change to interface to edit file + * + * Revision 1.34 1993/03/11 18:37:25 jont + * Added Intermal.Images including save and clean. Added other_operation to + * Editor for arbitrary bits of emacs lisp + * + * Revision 1.33 1993/03/10 16:30:56 jont + * Added editor substructure to MLWorks + * + * Revision 1.32 1993/02/18 16:56:08 matthew + * Added TypeRep signature in MLWorks.Internal + * + * Revision 1.31 1993/02/17 11:05:21 daveb + * Corrected string argument to Unimplemented for MLWorks.Time.Real.now. + * + * Revision 1.30 1993/01/05 16:54:24 richard + * Added some extra exceptions for the runtime system. + * + * Revision 1.29 1992/12/22 10:50:12 clive + * ExtendedArray should not be available at the top level + * + * Revision 1.28 1992/12/22 10:25:37 daveb + * Made ExtendedArray visible at top level. + * + * Revision 1.27 1992/12/22 10:05:26 clive + * Needed to define the type T in the Array structure + * + * Revision 1.26 1992/12/22 10:02:01 matthew + * Added 'agreed' Array and Vector structures. + * + * Revision 1.25 1992/12/01 13:05:26 matthew + * Fixed problem with IO + * + * Revision 1.24 1992/12/01 12:45:10 matthew + * Changed IO structure to mirror __pervasive_library + * + * Revision 1.23 1992/11/12 15:58:16 clive + * Added some rts support for tracing + * + * Revision 1.22 1992/11/10 13:14:23 richard + * Added StorageManager exception and changed the type of the + * StorageManager interface function. + * + * Revision 1.21 1992/11/02 10:06:49 richard + * Many changes. See MLWorks signature. + * + * Revision 1.20 1992/09/25 14:36:13 matthew + * Added Internal.string_to_real + * + * Revision 1.19 1992/09/23 16:16:41 daveb + * Added clear_eof function to IO (unimplemented). + * + * Revision 1.18 1992/09/01 14:34:40 richard + * Changed the OS information stuff to functions. Added Prod and + * Value exceptions. + * Implemented save. + * + * Revision 1.17 1992/08/28 15:00:49 clive + * Added a function to the pervasive_library to get debug_info from a + * function + * + * Revision 1.16 1992/08/28 08:26:28 richard + * Changed call to environment so that environment is not + * preserved across images. + * Added floating-point exceptions. + * + * Revision 1.15 1992/08/26 14:34:26 richard + * Rationalisation of the MLWorks structure. + * + * Revision 1.14 1992/08/25 16:27:11 richard + * Added ByteArray structure and writebf in FileIO. + * + * Revision 1.13 1992/08/24 14:16:46 davidt + * Added a faster implementation of FileIO.writef which + * doesn't allocate as many bytearrays. + * + * Revision 1.12 1992/08/20 12:44:05 richard + * Changed path of require of mlworks to use pervasive directory. + * + * Revision 1.11 1992/08/20 08:33:04 richard + * Enriched the Array structure. + * + * Revision 1.10 1992/08/18 16:40:49 richard + * Added real_to_string. + * + * Revision 1.9 1992/08/18 14:44:59 richard + * Changes to the MLWorks signature. See mlworks file for + * details. + * + * Revision 1.8 1992/08/17 11:05:12 richard + * Added MLWorks.System.Runtime.GC.interface. + * + * Revision 1.7 1992/08/15 17:32:57 davidt + * Put in MLWorks.IO.input_line function. + * + * Revision 1.6 1992/08/13 15:30:59 clive + * Added two functions to the debugger + * + * Revision 1.4 1992/08/12 14:21:36 davidt + * Took out copying of Array and String structures from the + * MLWorks structure in an attempt to see if NewJersey was + * getting confused and not inlining code for array updates. + * + * Revision 1.3 1992/08/11 05:59:23 richard + * Added load_wordset to Int structure. + * + * Revision 1.2 1992/08/10 15:26:16 davidt + * Changed MLworks structure to MLWorks + * + * Revision 1.1 1992/08/07 15:03:28 davidt + * Initial revision + * + * Revision 1.1 1992/05/18 15:40:36 clive + * Initial revision + *) + +(* This require is just for the pervasive modules. *) +fun require s = + use ("pervasive/" + ^ (case Char.fromString s of + SOME #" " => String.substring (s, 1, size s - 1) + | _ => s) + ^ ".sml"); + +require "mlworks"; + +local + exception Unimplemented of string + fun unimplemented (name:string) = + (TextIO.print ("unimplemented MLWorks pervasive: " ^ name ^ "\n"); + raise Unimplemented name; + Unsafe.cast 0) + + structure SMLBasisArray = Array + structure SMLBasisArraySlice = ArraySlice + structure SMLBasisVector = Vector + structure SMLBasisString = String + structure SMLBasisChar = Char + structure SMLBasisInt = Int + structure SMLBasisReal = Real + structure SMLBasisMath = Math + structure SMLBasisTime = Time + structure SMLBasisInt32 = Int32 + structure SMLBasisWord = Word + structure SMLBasisWord32 = Word32 + structure SMLBasisWord8 = Word8 + structure SMLBasisWord8Array = Word8Array + structure SMLBasisWord8ArraySlice = Word8ArraySlice + structure SMLBasisRealArray = RealArray + structure SMLBasisRealArraySlice = RealArraySlice + structure SMLBasisOption = Option + structure SMLBasisOS = OS + structure SMLBasisOSProcess = OS.Process +in +structure MLWorks : MLWORKS = + struct + + structure String = + struct + local + structure S = SMLBasisString + in + exception Substring = General.Subscript + exception Chr = General.Chr + exception Ord + val maxLen = S.maxSize + fun explode (s:string) = List.map S.str (S.explode s) + fun implode (l:string list) = S.concat l + val str = S.str + fun chr (i:int) = S.str (Char.chr i) + val sub = S.sub + val substring = S.substring + val op < = S.< + val op > = S.> + val op >= = S.>= + val op <= = S.<= + fun ordof (s, i) = SMLBasisChar.ord (sub (s, i)) + fun ord (s:string) = + case size s of + 1 => Char.ord (sub (s, 0)) + | _ => raise Ord + fun ml_string (s,max_size) = + let + fun to_digit n = Char.chr (n + Char.ord #"0") + fun aux ([],result:char list,_) = + S.implode (rev result) + | aux (_,result,0) = + S.implode (rev (#"\\" :: #"." :: #"." :: result)) + | aux (char::rest,result,n) = + let val newres = + case char of + #"\n" => #"\\"::char::result + | #"\t" => #"\\"::char::result + | #"\"" => #"\\"::char::result + | #"\\" => #"\\"::char::result + | c => + let val n = Char.ord c + in + if Int.< (n, 32) orelse Int.>= (n, 127) + then + let + val n1 = n div 10 + in + (to_digit (n mod 10)):: + (to_digit (n1 mod 10)):: + (to_digit (n1 div 10)):: + (#"\\")::result + end + else + c::result + end + in + aux (rest, newres, n-1) + end + in + aux (S.explode s,[], + if Int.<(max_size, 0) then ~1 else max_size) + end + fun implode_char ints = + S.implode (map SMLBasisChar.chr ints) + + end + end + + exception Interrupt + + structure Option = SMLBasisOption + + structure Char = + struct + type char = SMLBasisChar.char + fun ml_char c = String.ml_string(c, ~1) + val chr = SMLBasisChar.chr + val ord = SMLBasisChar.ord + val maxCharOrd = 255 + exception Chr = Chr + + (* Finally define these *) + val op < : char * char -> bool = op < + val op > : char * char -> bool = op > + val op <= : char * char -> bool = op <= + val op >= : char * char -> bool = op >= + end + + structure Integer = + struct + val makestring : int -> string = SMLBasisInt.toString + val print : int -> unit = fn i => TextIO.print (makestring i) + fun hexmakestring _ = unimplemented"hexmakestring" + fun hexprint _ = unimplemented"hexprint" + end + + structure Real = + struct + val makestring : real -> string = SMLBasisReal.toString + val print : real -> unit = fn r => TextIO.print (makestring r) + end + + structure Deliver = struct + datatype app_style = CONSOLE | WINDOWS + type deliverer = string * (unit -> unit) * app_style -> unit + type delivery_hook = deliverer -> deliverer + fun deliver (x,y,z) = (unimplemented "MLWorks.Deliver.deliver"; + ()) + fun with_delivery_hook _ = + unimplemented "MLWorks.Deliver.with_delivery_hook" + fun add_delivery_hook x = + (TextIO.print ("add_delivery_hook called"); + ()) + val exitFn = ref (fn () => + (unimplemented "MLWorks.Deliver.exitFn"; ())) + end + + val arguments = CommandLine.arguments + val name = CommandLine.name + + structure Threads = + struct + datatype 'a thread = Thread of { r : 'a } + exception Threads of string + + fun fork f = + (unimplemented "MLWorks.Threads.fork"; + fn (a) => Thread {r=f(a)}) + fun yield () = (unimplemented "MLWorks.Threads.yield"; ()) + + datatype 'a result = + Running (* still running *) + | Waiting (* waiting *) + | Sleeping (* sleeping *) + | Result of 'a (* completed, with this result *) + | Exception of exn (* exited with this uncaught exn *) + | Died (* died (e.g. bus error) *) + | Killed (* killed *) + | Expired (* no longer exists (from a previous image) *) + + fun result (Thread{r}) = (unimplemented "MLWorks.Threads.result"; + Result r) + fun sleep _ = (unimplemented "MLWorks.Threads.sleep"; ()) + fun wake _ = (unimplemented "MLWorks.Threads.wake"; ()) + + structure Internal = struct + type thread_id = unit + fun id _ = (unimplemented "MLWorks.Threads.Internal.id"; ()) + fun get_id _ = (unimplemented "MLWorks.Threads.Internal.get_id";()) + fun children _ = + (unimplemented "MLWorks.Threads.Internal.children";[]) + fun parent _ = (unimplemented "MLWorks.Threads.Internal.parent";()) + fun all _ = (unimplemented "MLWorks.Threads.Internal.all";[]) + fun kill _ = (unimplemented "MLWorks.Threads.Internal.kill";()) + fun raise_in _ = + (unimplemented "MLWorks.Threads.Internal.raise_in";()) + fun yield_to _ = + (unimplemented "MLWorks.Threads.Internal.yield_to";()) + fun state _ = (unimplemented "MLWorks.Threads.Internal.state"; + Result ()) + fun get_num _ = (unimplemented "MLWorks.Threads.Internal.get_num"; + 0) + fun set_handler _ = + (unimplemented "MLWorks.Threads.Internal.set_handler"; ()) + fun reset_fatal_status _ = + (unimplemented "MLWorks.Threads.Internal.reset_fatal_status"; + ()) + structure Preemption = + struct + fun start _ = + (unimplemented "MLWorks.Threads.Internal.Preemption.start"; + ()) + fun stop _ = + (unimplemented "MLWorks.Threads.Internal.Preemption.stop";()) + fun on _ = + (unimplemented "MLWorks.Threads.Internal.Preemption.on"; + false) + fun get_interval _ = + (unimplemented "MLWorks.Threads.Internal.Preemption.get_interval"; 0) + fun set_interval _ = + (unimplemented "MLWorks.Threads.Internal.Preemption.set_interval"; ()) + fun enter_critical_section () = + (unimplemented "MLWorks.Threads.Internal.Preemption.enter_critical_section"; + ()) + fun exit_critical_section () = + (unimplemented "MLWorks.Threads.Internal.Preemption.exit_critical_section"; + ()) + fun in_critical_section () = + (unimplemented "MLWorks.Threads.Internal.Preemption.exit_critical_section"; + false) + end + end + end + + exception Save of string + fun save (filename, function) = + (SMLofNJ.exportFn (filename, + fn _ => (function(); OS.Process.success)); + function) + + fun deliver _ = unimplemented "MLWorks.deliver" + + fun exec_save _ = unimplemented "MLWorks.exec_save" + + structure OS = + struct + fun arguments () = + case CommandLine.arguments () + of [] => [] + | program_name::rest => rest + end + + structure Debugger = + struct + fun default_break s = TextIO.print("Break at " ^ s ^ "\n") + val break_hook = ref default_break + fun break s = (!break_hook) s + end + + structure Internal = + struct + local + fun w8vectorToString (v:Word8Vector.vector):string = + let fun b2c i = Char.chr (Word8.toInt (Word8Vector.sub (v, i))) + in CharVector.tabulate (Word8Vector.length v, b2c) + end + + fun stringToW8vector (s:string):Word8Vector.vector = + let fun c2b i = Word8.fromInt (Char.ord (String.sub (s, i))) + in Word8Vector.tabulate (SMLBasisString.size s, c2b) + end + in + + exception Save of string + fun save (s, f) = (unimplemented "Internal.save"; f) + fun execSave (s, f) = (unimplemented "Internal.execSave"; f) + val text_preprocess = ref (fn (f : int -> string ) => f) + fun real_to_string (r, i) = SMLBasisReal.toString (r) + exception StringToReal + + fun string_to_real string = + case SMLBasisReal.fromString string of + NONE => raise StringToReal + | SOME r => r + + structure Images = + struct + fun clean _ = () + val save = save + exception Table of string + fun table _ = [] + end + + structure Types = + struct + (* These are all somewhat bogus. *) + type word8 = SMLBasisWord8.word + type int8 = int + type word16 = int + type int16 = int + type word32 = SMLBasisWord32.word + type int32 = SMLBasisInt32.int + datatype option = datatype SMLBasisOption.option + datatype time = datatype MLWTime.time + end + + structure Error = + struct + type syserror = Posix.Error.syserror + exception SysErr = SMLBasisOS.SysErr + val errorMsg = Posix.Error.errorMsg + val errorName = Posix.Error.errorName + val syserror = Posix.Error.syserror + end + + structure IO = + struct + exception Io of {cause: exn, name: string, function: string} + datatype file_desc = FILE_DESC of int + datatype access_mode = datatype Posix.FileSys.access_mode + + structure W8 = Word8 + structure W32 = SMLBasisWord32 + structure W8A = Word8Array + structure W8S = Word8ArraySlice + + fun stringToW8S (s, start, len) = + let fun c2b i = W8.fromInt (Char.ord (String.sub (s, start+i))) + in + W8S.full (W8A.tabulate (len, c2b)) + end + + fun posixFD (FILE_DESC fd) = + Posix.FileSys.wordToFD (W32.fromInt fd) + + fun write (fd, s, start, len) = + Posix.IO.writeArr (posixFD fd, stringToW8S (s, start, len)) + + fun read (fd, n:int) = + w8vectorToString (Posix.IO.readVec (posixFD fd, n)) + + fun seek (fd, offset, whence) = + let val w = (case whence of + 0 => Posix.IO.SEEK_SET + | 1 => Posix.IO.SEEK_CUR + | 2 => Posix.IO.SEEK_END + | _ => (unimplemented "seek whence"; + Posix.IO.SEEK_END)) + in + Posix.IO.lseek (posixFD fd, offset, w) + end + + fun close fd = Posix.IO.close (posixFD fd) + + fun can_input fd = + let val (_, mode) = Posix.IO.getfl (posixFD fd) + in + (case mode of + Posix.IO.O_RDONLY => 0 + | Posix.IO.O_RDWR => 0 + | Posix.IO.O_WRONLY => 1) + end + end + + structure StandardIO = + struct + type IOData = {input: {descriptor: IO.file_desc Types.option, + get: int -> string, + get_pos: (unit -> int) Types.option, + set_pos: (int -> unit) Types.option, + can_input: (unit-> bool) Types.option, + close: unit->unit}, + output: {descriptor: IO.file_desc Types.option, + put: {buf:string,i:int,sz:int Types.option} -> int, + get_pos: (unit -> int) Types.option, + set_pos: (int -> unit) Types.option, + can_output: (unit-> bool) Types.option, + close: unit->unit}, + error: {descriptor: IO.file_desc Types.option, + put: {buf:string,i:int,sz:int Types.option} -> int, + get_pos: (unit -> int) Types.option, + set_pos: (int -> unit) Types.option, + can_output: (unit->bool) Types.option, + close: unit-> unit}, + access: (unit->unit)->unit} + + local + fun put_ {buf:string,i:int,sz:int Types.option} : int = + let val j = case sz of + SOME s => i + s + | NONE => SMLBasisString.size buf + val s = SMLBasisString.substring (buf, i, j) + in + TextIO.print (s); + SMLBasisString.size s + end + fun close_ () = + (TextIO.print ("D: change_nj.sml close_ called\n"); + ()) + val dummyIO:IOData = { + output = { descriptor = NONE, + put = put_, + get_pos = NONE, + set_pos = NONE, + can_output = NONE, + close = close_ }, + error = { descriptor= NONE, + put = put_, + get_pos = NONE, + set_pos = NONE, + can_output = NONE, + close = close_ }, + input = { descriptor = NONE, + get = fn _ => (unimplemented "IOData.get"; + ""), + get_pos = NONE, + set_pos = NONE, + close = close_, + can_input = NONE }, + access = fn f =>f() } + in + fun currentIO () = (dummyIO) + fun redirectIO x = (TextIO.print "D: redirectIO called\n"; ()) + fun resetIO () = (TextIO.print "D: resetIO called\n"; ()) + fun print _ = unimplemented "print" + fun printError _ = unimplemented "printError" + end + end + + structure Bits : BITS = + struct + local + structure W = SMLBasisWord32 + fun lift (f) = + fn (x:int, y:int) => + W.toIntX (f (W.fromInt x, W.fromInt y)) + fun lifts (f) = + fn (x:int, y:int) => + W.toIntX (f (W.fromInt x, Word31.fromInt y)) + in + val andb = lift W.andb + val orb = lift W.orb + val xorb = lift W.xorb + val lshift = lifts W.<< + val rshift = lifts W.>> + val arshift = lifts W.~>> + fun notb (x) = W.toIntX (W.notb (W.fromInt x)) + end + end + + structure Word32 = + struct + local + (* open NewJersey.Bits *) + structure W = SMLBasisWord32 + type w32 = W.word + fun lifts (f) = + fn (x:w32, y:word) => + (f (x, Word31.fromLarge (SMLBasisWord.toLarge y))):w32 + in + val word32_lshift : w32 * word -> w32 = lifts W.<< + val word32_rshift : w32 * word -> w32 = lifts W.>> + val word32_arshift : w32 * word -> w32 = lifts W.~>> + val word32_orb : w32 * w32 -> w32 = W.orb + val word32_xorb : w32 * w32 -> w32 = W.xorb + val word32_andb : w32 * w32 -> w32 = W.andb + val word32_notb : w32 -> w32 = W.notb + end + end + + structure Word = + struct + local + type word = SMLBasisWord.word + type w = Word31.word + in + val word_lshift = SMLBasisWord.<< + val word_rshift : word * w -> word = SMLBasisWord.>> + val word_arshift : word * w -> word = SMLBasisWord.~>> + val word_orb : word * word -> word = SMLBasisWord.orb + val word_xorb : word * word -> word = SMLBasisWord.xorb + val word_andb : word * word -> word = SMLBasisWord.andb + val word_notb : word -> word = SMLBasisWord.notb + end + end + + structure Array : ARRAY = + struct + open SMLBasisArray + exception Size + exception Subscript + val arrayoflist = SMLBasisArray.fromList + end + + structure ByteArray : BYTEARRAY = + struct + local + structure W8A = SMLBasisWord8Array + structure W8S = SMLBasisWord8ArraySlice + structure W8 = SMLBasisWord8 + structure S = SMLBasisString + structure C = SMLBasisChar + in + type bytearray = W8A.array + + exception Range of int + exception Size + exception Subscript + exception Substring + exception Find + + fun array (len, init) = W8A.array (len, (W8.fromInt init)) + val length = W8A.length + fun update (arr, i, x) = W8A.update (arr, i, (W8.fromInt x)) + fun sub (arr, i) = W8.toInt (W8A.sub (arr, i)) + fun arrayoflist ilist = W8A.fromList (map W8.fromInt ilist) + fun tabulate (n, f) = W8A.tabulate (n, fn (i) => W8.fromInt (f i)) + val from_list = arrayoflist + fun to_list arr = List.tabulate (length arr, fn i => sub (arr, i)) + fun from_string s = + tabulate (S.size s, fn i => C.ord (S.sub (s, i))) + fun substring (arr, start, len) = + let fun f i = C.chr (sub (arr, start + i)) + in CharVector.tabulate (len, f) + end + fun to_string arr = substring (arr, 0, length arr) + fun fill (arr, x) = + let val b = W8.fromInt x + in W8A.modify (fn _ => b) arr + end + fun map_index f arr = + tabulate (length arr, fn i => f (i, sub (arr, i))) + fun map f arr = map_index (f o #2) arr + fun iterate_index f arr = + W8A.appi (fn (i, w) => f (i, W8.toInt w)) arr + fun iterate f arr = iterate_index (f o #2) arr + fun rev arr = + let val len = length arr + in W8A.tabulate (len, fn i => W8A.sub (arr, (len - 1) - i)) + end + fun duplicate arr = + let val result = W8A.array (length arr, 0w0) + in + W8A.copy { src = arr, dst = result, di = 0 }; + result + end + fun subarray (arr, start, end_) = + let val result = W8A.array (end_ - start, 0w0) + in + W8S.copy { src = W8S.slice (arr, start, SOME end_), + dst = result, + di = 0 }; + result + end + fun append (arr1, arr2) = + let val len1 = length arr1 + val len2 = length arr2 + val result = W8A.array (len1 + len2, 0w0) + in + W8A.copy {src = arr1, dst = result, di = 0}; + W8A.copy {src = arr2, dst = result, di = len1}; + result + end + fun reducel_index f (init, arr) = + let fun g (i, w, state) = f (i, state, W8.toInt w) + in W8A.foldli g init arr + end + fun reducer_index f (arr, init) = + let fun g (i, w, state) = f (i, W8.toInt w, state) + in W8A.foldri g init arr + end + fun reducel f (init, arr) = + reducel_index (fn (_, state, x) => f (state, x)) (init, arr) + fun reducer f (arr, init) = + reducer_index (fn (_, x, state) => f (x, state)) (arr, init) + fun copy (src, start, end_, dst, start') = + W8S.copy { src = W8S.slice (src, start, SOME end_), + dst = dst, + di = start'} + fun fill_range (arr, start, end_, x) = + let val w = W8.fromInt x + in W8S.modify (fn _ => w) (W8S.slice (arr, start, SOME end_)) + end + local + fun find' f arr = W8A.findi (fn (_, w) => f (W8.toInt w)) arr + in + fun find f arr = + case find' f arr of + NONE => raise Find + | SOME (i, _) => i + fun find_default (f, default) arr = + case find' f arr of + NONE => default + | SOME (i, _) => i + end + val maxLen = W8A.maxLen + + end + end + + structure FloatArray : FLOATARRAY = + struct + local + structure A = SMLBasisRealArray + structure S = SMLBasisRealArraySlice + in + type floatarray = A.array + exception Range of int + exception Size + exception Subscript + exception Find + val array = A.array + val length = A.length + val sub = A.sub + val update = A.update + val tabulate = A.tabulate + val arrayoflist = A.fromList + val from_list = A.fromList + fun to_list arr = List.tabulate (length arr, fn i => sub (arr, i)) + fun fill (arr, x) = A.modify (fn _ => x) arr + fun map_index f arr = + tabulate (length arr, fn i => f (i, (sub (arr, i)))) + fun map f arr = map_index (f o #2) arr + val iterate = A.app + val iterate_index = A.appi + fun rev arr = + let val len = length arr + in tabulate (len, fn i => sub (arr, (len - 1) - i)) + end + fun duplicate arr = + let val result = array (length arr, 0.0) + in + A.copy { src = arr, dst = result, di = 0 }; + result + end + fun subarray (arr, start, end_) = + let val result = array (end_ - start, 0.0) + in + S.copy { src = S.slice (arr, start, SOME end_), + dst = result, + di = 0 }; + result + end + fun append (arr1, arr2) = + let val len1 = length arr1 + val len2 = length arr2 + val result = array (len1 + len2, 0.0) + in + A.copy {src = arr1, dst = result, di = 0}; + A.copy {src = arr2, dst = result, di = len1}; + result + end + fun reducel_index f (init, arr) = + let fun g (i, x, state) = f (i, state, x) + in A.foldli g init arr + end + fun reducer_index f (arr, init) = A.foldri f init arr + fun reducel f (init, arr) = + reducel_index (fn (_, state, x) => f (state, x)) (init, arr) + fun reducer f (arr, init) = A.foldr f init arr + fun copy (src, start, end_, dst, start') = + S.copy { src = S.slice (src, start, SOME end_), + dst = dst, + di = start'} + fun fill_range (arr, start, end_, x) = + S.modify (fn _ => x) (S.slice (arr, start, SOME end_)) + local + fun find' f arr = A.findi (fn (_, x) => f x) arr + in + fun find f arr = + case find' f arr of + NONE => raise Find + | SOME (i, _) => i + fun find_default (f, default) arr = + case find' f arr of + NONE => default + | SOME (i, _) => i + end + val maxLen = A.maxLen + + end + end + + structure ExtendedArray : EXTENDED_ARRAY = + struct + local + structure A = SMLBasisArray + structure S = SMLBasisArraySlice + in + type 'a array = 'a A.array + exception Range of int + exception Size + exception Subscript + exception Find + val array = A.array + val length = A.length + val sub = A.sub + val update = A.update + val tabulate = A.tabulate + val arrayoflist = A.fromList + val from_list = A.fromList + fun to_list arr = List.tabulate (length arr, fn i => sub (arr, i)) + fun fill (arr, x) = A.modify (fn _ => x) arr + fun map_index f arr = + tabulate (length arr, fn i => f (i, (sub (arr, i)))) + fun map f arr = map_index (f o #2) arr + val iterate = A.app + val iterate_index = A.appi + fun rev arr = + let val len = length arr + in tabulate (len, fn i => sub (arr, (len - 1) - i)) + end + local + fun alloc (len, proto) = + if len = 0 + then tabulate (0, fn i => sub (proto, i)) + else array (len, sub (proto, 0)) + in + fun duplicate arr = + let val result = alloc (length arr, arr) + in + A.copy { src = arr, dst = result, di = 0 }; + result + end + fun subarray (arr, start, end_) = + let val result = alloc (end_ - start, arr) + in + S.copy { src = S.slice (arr, start, SOME end_), + dst = result, + di = 0 }; + result + end + fun append (arr1, arr2) = + let val len1 = length arr1 + val len2 = length arr2 + val result = alloc (len1 + len2, arr1) + in + A.copy {src = arr1, dst = result, di = 0}; + A.copy {src = arr2, dst = result, di = len1}; + result + end + end + fun reducel_index f (init, arr) = + let fun g (i, x, state) = f (i, state, x) + in A.foldli g init arr + end + fun reducer_index f (arr, init) = A.foldri f init arr + fun reducel f (init, arr) = + reducel_index (fn (_, state, x) => f (state, x)) (init, arr) + fun reducer f (arr, init) = A.foldr f init arr + fun copy (src, start, end_, dst, start') = + S.copy { src = S.slice (src, start, SOME end_), + dst = dst, + di = start'} + fun fill_range (arr, start, end_, x) = + S.modify (fn _ => x) (S.slice (arr, start, SOME end_)) + local + fun find' f arr = A.findi (fn (_, x) => f x) arr + in + fun find f arr = + case find' f arr of + NONE => raise Find + | SOME (i, _) => i + fun find_default (f, default) arr = + case find' f arr of + NONE => default + | SOME (i, _) => i + end + val maxLen = A.maxLen + + end + end + + structure Vector : VECTOR = + struct + local + structure V = SMLBasisVector + in + type 'a vector = 'a V.vector + exception Size + exception Subscript + val vector = V.fromList + val tabulate = V.tabulate + val sub = V.sub + val length = V.length + val maxLen = V.maxLen + end + end + + structure Value = + struct + type T = unit + type ml_value = T + exception Value of string + val cast = Unsafe.cast + val ccast = Unsafe.cast + datatype print_options = + DEFAULT | + OPTIONS of {depth_max : int, + string_length_max : int, + indent : bool, + tags : bool} + + fun unsafe_plus _ = unimplemented "unsafe_plus" + fun unsafe_minus _ = unimplemented "unsafe_minus" + + val unsafe_array_sub = Array.sub + val unsafe_array_update = Array.update + + val unsafe_bytearray_sub = ByteArray.sub + val unsafe_bytearray_update = ByteArray.update + + val unsafe_floatarray_sub = FloatArray.sub + val unsafe_floatarray_update = FloatArray.update + + fun unsafe_record_sub (x, _) = unimplemented "unsafe_record_sub" + fun unsafe_record_update _ = unimplemented "unsafe_record_update" + + fun unsafe_string_sub (s, i) = Char.ord (String.sub (s, i)) + fun unsafe_string_update _ = unimplemented "unsafe_string_update" + + fun alloc_pair _ = unimplemented "alloc_pair" + fun alloc_string _ = unimplemented "Value.alloc_string" + fun alloc_vector _ = unimplemented "alloc_vector" + + fun list_to_tuple _ = unimplemented "list_to_tuple" + fun tuple_to_list _ = unimplemented "tuple_to_list" + local + (* encode a 64bit float as a Word8Vector with + big endian order. *) + fun packReal64Big r = + let val r64a = Real64Array.array (1, r) + (* i386 is little endian *) + fun load_byte i = + Unsafe.Word8Array.sub (r64a, 8 - 1 - i) + in Word8Vector.tabulate (8, load_byte) + end + fun unpackReal64Big v = + let val r64a = Real64Array.array (1, 0.0) + fun store_byte (i, b) = + Unsafe.Word8Array.update (r64a, 8 - 1 - i, b) + in Word8Vector.appi store_byte v; + Real64Array.sub (r64a, 0) + end + in + fun string_to_real (s:string):real = + unpackReal64Big (stringToW8vector s) + fun real_to_string (r:real):string = + w8vectorToString (packReal64Big r) + end + fun real_equal (x, y) = SMLBasisReal.== (x, y) + fun arctan x = SMLBasisMath.atan x + fun cos x = SMLBasisMath.cos x + fun exp x = SMLBasisMath.exp x + fun sin x = SMLBasisMath.cos x + fun sqrt x = SMLBasisMath.sqrt x + + fun print _ = unimplemented "Value.print" + fun primary _ = unimplemented "Value.primary" + fun header _ = unimplemented "Value.header" + fun update_header _ = unimplemented "MLWorks.Internal.Value.update_header" + fun pointer _ = unimplemented "Value.pointer" + fun update _ = unimplemented "MLWorks.Internal.Value.update" + fun sub _ = unimplemented "MLWorks.Internal.Value.sub" + fun update_byte _ = unimplemented "MLWorks.Internal.Value.update_byte" + fun sub_byte _ = (unimplemented "MLWorks.Internal.Value.sub_byte"; 0) + fun update_header _ = unimplemented "MLWorks.Internal.Value.update_header" + fun exn_name _ = (unimplemented "MLWorks.Internal.Value.exn_name"; "") + fun code_name _ = (unimplemented "MLWorks.Internal.Value.code_name"; "") + fun exn_argument _ = unimplemented "MLWorks.Internal.Value.exn_argument" + fun exn_name_string _ = unimplemented "MLWorks.Internal.Value.exn_name_string" + fun update_exn _ = unimplemented "Value.update_exn" + fun update_exn_cons _ = unimplemented "Value.update_exn_cons" + + structure Frame = + struct + type frame = unit + + fun frame_call f = (unimplemented "MLWorks.Internal.Value.Frame.frame_call"; f ()) + fun frame_next _ = (unimplemented "MLWorks.Internal.Value.Frame.frame_next"; (false, (), 0)) + fun frame_offset _ = unimplemented "MLWorks.Internal.Value.Frame.frame_offset" + fun frame_double _ = unimplemented "MLWorks.Internal.Value.Frame.frame_double" + fun frame_allocations _ = (unimplemented "MLWorks.Internal.Value.Frame.frame_allocations"; false) + fun is_ml_frame _ = (unimplemented "MLWorks.Internal.Value.Frame.is_ml_frame"; false) + fun sub _ = unimplemented "MLWorks.Internal.Value.Frame.sub" + fun update _ = unimplemented "MLWorks.Internal.Value.Frame.update" + fun current _ = unimplemented "MLWorks.Internal.Value.Frame.current" + end + end + + structure Trace = + struct + exception Trace of string + fun intercept _ = unimplemented "MLWorks.Internal.Trace.intercept" + fun replace _ = unimplemented "MLWorks.Internal.Trace.replace" + fun restore _ = unimplemented "MLWorks.Internal.Trace.restore" + fun restore_all _ = unimplemented "MLWorks.Internal.Trace.restore_all" + datatype status = INTERCEPT | NONE | REPLACE | UNTRACEABLE + fun status _ = (unimplemented "MLWorks.Internal.Trace.status"; NONE) + end + + structure Dynamic = + struct + type dynamic = int ref * int ref + type type_rep = int ref + exception Coerce of type_rep * type_rep + + val generalises_ref : (type_rep * type_rep -> bool) ref = + ref (fn _ => false) + + local + fun generalises data = (!generalises_ref) data + + val get_type = Value.cast (fn (a,b) => b) + val get_value = Value.cast (fn (a,b) => a) + in + fun coerce (d,t) = + if generalises (get_type d,t) then + get_value d + else + raise Coerce(get_type d,t) + end + end + + structure Exit = + struct + local + structure P = SMLBasisOSProcess + structure W = SMLBasisWord32 + in + type key = int + type status = W.word + val success = W.fromInt P.success + val failure = W.fromInt P.failure + val uncaughtIOException = W.fromInt 2 + val badUsage = W.fromInt 3 + val stop = W.fromInt 4 + val save = W.fromInt 5 + val badInput = W.fromInt 6 + fun atExit f = (P.atExit f; 0) + fun removeAtExit key = unimplemented "removeAtExit" + fun exit w = (TextIO.print "D: exit called\n"; Unsafe.cast w) + fun terminate w = P.terminate (W.toIntX w) + end + end + + structure Debugger = + struct + local + fun f (s:string) = (unimplemented "break_hook"; ()) + in + val break_hook = ref f + fun break s = unimplemented "break" + end + end + + structure FileIO = + struct + datatype offset = BEG | CUR | END + + fun flush stream = BinIO.flushOut stream + + fun openf s = BinIO.openOut + + (* to close: + - flush our buffer, + - do an fsync, + - close the file. + The fsync is required to avoid MLWorks bug 561, q.v. + The fsync is very ugly. Nick Haines 14-Mar-94 *) + + fun closef s = BinIO.closeOut + + fun seekf (stream, i, p) = + (unimplemented "seekf"; ()) + + fun writebf (stream, bytearray, start, length) = + let val aslice = Word8ArraySlice.slice (bytearray, start, + SOME(length)) + in + BinIO.output (stream, Word8ArraySlice.vector (aslice)) + end + + fun write_byte (stream, byte) = BinIO.output1 (stream, byte) + + fun writef (stream, s:string) = + let fun write1 (c:char) = + let val byte = Word8.fromInt(ord c) + in write_byte (stream, byte) + end + val sz = size s + fun loop (i) = + if i = sz then () + else (write1 (String.sub (s, i)); loop (1 + i)) + in + loop (0) + end + + end + + structure Runtime = + struct + exception Unbound of string + fun environment name = + Unsafe.cast (nj_environment name) (* Defined in nj_env.sml *) + + val modules = ref ([] : (string * Value.T * Value.T) list) + + structure Loader = + struct + exception Load of string + fun load_module name = + (unimplemented "MLWorks.Internal.Runtime.Loader.load_module"; (name, ())) + + fun load_wordset _ = + (unimplemented "MLWorks.Internal.Runtime.Loader.load_wordset"; []) + end + + structure Memory = + struct + val gc_message_level = ref 0 + val max_stack_blocks = ref 0 + fun collect _ = unimplemented "MLWorks.Internal.Runtime.Memory.collect" + fun collect_all _ = unimplemented "MLWorks.Internal.Runtime.Memory.collect_all" + fun promote_all _ = unimplemented "MLWorks.Internal.Runtime.Memory.promote_all" + fun collections _ = + (unimplemented "MLWorks.Internal.Runtime.Memory.collections"; (0,0)) + end + + structure Event = + struct + datatype T = SIGNAL of int + exception Signal of string + fun signal _ = unimplemented "MLWorks.Internal.Runtime.Event.signal" + fun stack_overflow_handler _ = unimplemented "MLWorks.Internal.Runtime.Event.stack_overflow_handler" + fun interrupt_handler _ = unimplemented "MLWorks.Internal.Runtime.Event.interrput_handler" + + end + + end + end + end + + structure Profile = + struct + type manner = int + type function_id = string + type cost_centre_profile = unit + + datatype object_kind = + RECORD + | PAIR + | CLOSURE + | STRING + | ARRAY + | BYTEARRAY + | OTHER (* includes weak arrays, code objects *) + | TOTAL (* used when specifying a profiling manner *) + + datatype large_size = + Large_Size of + {megabytes : int, + bytes : int} + + datatype object_count = + Object_Count of + {number : int, + size : large_size, + overhead : int} + + type object_breakdown = (object_kind * object_count) list + + datatype function_space_profile = + Function_Space_Profile of + {allocated : large_size, + copied : large_size, + copies : large_size list, + allocation : object_breakdown list} + + datatype function_caller = + Function_Caller of + {id: function_id, + found: int, + top: int, + scans: int, + callers: function_caller list} + + datatype function_time_profile = + Function_Time_Profile of + {found: int, + top: int, + scans: int, + depth: int, + self: int, + callers: function_caller list} + + datatype function_profile = + Function_Profile of + {id: function_id, + call_count: int, + time: function_time_profile, + space: function_space_profile} + + datatype general_header = + General of + {data_allocated: int, + period: Internal.Types.time, + suspended: Internal.Types.time} + + datatype call_header = + Call of {functions : int} + + datatype time_header = + Time of + {data_allocated: int, + functions: int, + scans: int, + gc_ticks: int, + profile_ticks: int, + frames: real, + ml_frames: real, + max_ml_stack_depth: int} + + datatype space_header = + Space of + {data_allocated: int, + functions: int, + collections: int, + total_profiled : function_space_profile} + + type cost_header = unit + + datatype profile = + Profile of + {general: general_header, + call: call_header, + time: time_header, + space: space_header, + cost: cost_header, + functions: function_profile list, + centres: cost_centre_profile list} + + datatype options = Options of { scan : int, + selector : function_id -> manner} + + datatype 'a result = + Result of 'a + | Exception of exn + + exception ProfileError of string + + fun profile (Options {scan, selector}) f a = + (unimplemented "MLWorks.Profile.profile"; + Unsafe.cast 0) + + fun make_manner {time, space, copies, calls, depth, breakdown} = + (unimplemented "MLWorks.Profile.make_manner"; + Unsafe.cast 0) + + end + + end +end; + +local + structure MLWorksGeneral = + struct + open General + val op <> = op <> + end +in +structure General = MLWorksGeneral +end diff --git a/src/make/dummy_make.sml b/src/make/dummy_make.sml index 18f98d24..6a319d2a 100644 --- a/src/make/dummy_make.sml +++ b/src/make/dummy_make.sml @@ -54,8 +54,6 @@ * *) -Shell.Options.set (Shell.Options.Language.requireReservedWord,false); - local datatype Path = ABS of string list| REL of string list fun strip (#"\t" :: rest) = strip rest @@ -87,14 +85,11 @@ local let val s = TextIO.openIn f fun doline acc = - let - val line = TextIO.inputLine s - in - if line = "" then rev acc - else case getrequire line of - SOME r => doline (r ::acc) - | _ => doline acc - end + case TextIO.inputLine s of + NONE => rev acc + | SOME line => case getrequire line of + SOME r => doline (r ::acc) + | _ => doline acc val res = doline [] in TextIO.closeIn s; diff --git a/src/make/nj_env.sml b/src/make/nj_env.sml new file mode 100644 index 00000000..9210c872 --- /dev/null +++ b/src/make/nj_env.sml @@ -0,0 +1,203 @@ +(* New Jersey emulation of runtime environment + * + * Copyright (C) 1996 Harlequin Ltd + * + * $Log: nj_env.sml,v $ + * Revision 1.1 1996/01/23 10:41:34 matthew + * new unit + * Emulation of runtime environment + * + *) + + +(* Also needed for MLWorks.Internal.Types.time *) +structure MLWTime = + struct + datatype time = TIME of int * int * int + local val lobits = 20 + structure W = LargeWord + fun split secs = + let val w = W.fromLargeInt secs + val hi = W.toInt (W.>> (w, Word.fromInt lobits)) + val one = W.fromInt 1 + val mask = W.- (W.<< (one, Word.fromInt lobits), one) + val lo = W.toInt (W.andb (w, mask)) + in (hi, lo) + end + fun unsplit (hi, lo) = + W.toLargeInt (W.+ (W.<< (W.fromInt hi, Word.fromInt lobits), + W.fromInt lo)) + in + fun fromTime t : time = + let val secs = Time.toSeconds t + val (hi, lo) = split secs + val rem = Time.- (t, Time.fromSeconds secs) + val micro = LargeInt.toInt (Time.toMicroseconds rem) + in TIME (hi, lo, micro) + end + fun toTime (TIME (hi, lo, micro)) : Time.time = + Time.+ (Time.fromSeconds (unsplit (hi, lo)), + Time.fromMicroseconds (LargeInt.fromInt micro)) + fun fromReal r = fromTime (Time.fromReal r) + fun toReal mt = Time.toReal (toTime mt) + fun op + (x, y) = fromTime (Time.+ (toTime x, toTime y)) + fun op - (x, y) = fromTime (Time.- (toTime x, toTime y)) + end + end + +local + (* A handful of environment functions that we need *) + (* We only need the functions that actually get called by the + compiler here *) + + (* http://www.standardml.org/Basis/os-process.html#SIG:OS_PROCESS.getEnv:VAL *) + fun environment () : string list = + (print "D: os unix environment called\n"; + Posix.ProcEnv.environ ()) + + (* http://www.standardml.org/Basis/os-file-sys.html#SIG:OS_FILE_SYS.chDir:VAL *) + val setwd = OS.FileSys.chDir + + (* http://www.standardml.org/Basis/os-file-sys.html#SIG:OS_FILE_SYS.getDir:VAL *) + val getwd = OS.FileSys.getDir + + (* http://www.standardml.org/Basis/os-file-sys.html#SIG:OS_FILE_SYS.realPath:VAL *) + val realpath = OS.FileSys.realPath + + (* stat is a pain to emulate *) + local + (* layouts must match definitions in unix/_unixos.sml *) + structure S = struct + type mode = int + end + datatype dev = DEV of int + datatype ino = I_NODE of int + structure ST = + struct + type stat = {dev : dev, + ino : ino, + mode : S.mode, + nlink : int, + uid : int, + gid : int, + rdev : int, + size : Position.int, + atime : MLWTime.time, + mtime : MLWTime.time, + ctime : MLWTime.time, + blksize: int, + blocks : int, + (* append the original object at the end *) + (* hoping that the layout will actually be *) + (* at the end *) + zzwrapped : Posix.FileSys.ST.stat + } + end + structure P = Posix.FileSys + structure PE = Posix.ProcEnv + fun wrap (s:P.ST.stat) : ST.stat = + {dev = DEV (SysWord.toInt (P.devToWord (P.ST.dev s))), + ino = I_NODE (SysWord.toInt (P.inoToWord (P.ST.ino s))), + mode = SysWord.toInt (P.S.toWord (P.ST.mode s)), + nlink = P.ST.nlink s, + uid = SysWord.toInt (PE.uidToWord (P.ST.uid s)), + gid = SysWord.toInt (PE.gidToWord (P.ST.gid s)), + rdev = 0, + size = P.ST.size s, + atime = MLWTime.fromTime (P.ST.atime s), + mtime = MLWTime.fromTime (P.ST.mtime s), + ctime = MLWTime.fromTime (P.ST.ctime s), + blksize = 4096, (* used as buffer size for mkUnixWriter *) + blocks = ((P.ST.size s) div 512) + 1, + zzwrapped = s + } + + in + fun stat (pathname:string) : ST.stat = wrap (P.stat pathname) + fun fstat (fd) : ST.stat = wrap (P.fstat fd) + fun isdir (s:ST.stat) = P.ST.isDir (#zzwrapped s) + fun mkdir (pathname:string, mode:S.mode):unit = + P.mkdir (pathname, P.S.fromWord (SysWord.fromInt mode)) + end + + local + exception Openf + structure P = Posix.FileSys + structure W = Word + fun bit (pos) = W.toInt (W.<< (0w1, W.fromInt pos)) + fun anyp (i, mask) = not (W.andb (W.fromInt i, W.fromInt mask) = 0w0) + fun flag (i, mask, f) = if anyp (i, mask) then f else P.O.flags [] + in + val o_rdonly = bit 0 + val o_wronly = bit 1 + val o_append = bit 2 + val o_creat = bit 3 + val o_trunc = bit 4 + fun open_ (pathname:string, flags:int, perms:int) : P.file_desc = + let val omode = (if anyp (flags, o_rdonly) then P.O_RDONLY + else if anyp (flags, o_wronly) then P.O_WRONLY + else raise Openf) + val oflags = P.O.flags [flag (flags, o_append, P.O.append), + flag (flags, o_trunc, P.O.trunc)] + val operms = P.S.fromWord (Word32.fromInt perms) + in + if anyp (flags, o_creat) + then P.createf (pathname, omode, oflags, operms) + else P.openf (pathname, omode, oflags) + end + end + + (* http://www.smlnj.org/doc/SMLofNJ/pages/unsafe.html#SIG:UNSAFE.cast:VAL *) + type T = int ref + val tcast : 'a -> T = Unsafe.cast + + val env_refs = ref [] : (string * T) list ref + + fun add_env_function (name,f) = + env_refs := (name,tcast f) :: !env_refs + + (* These may be all we need *) + val _ = + (add_env_function ("system os unix environment",environment); + add_env_function ("system os unix setwd",setwd); + add_env_function ("system os unix getwd",getwd); + add_env_function ("system os unix realpath",realpath); + add_env_function ("POSIX.FileSys.fstat", fstat); + add_env_function ("POSIX.FileSys.stat", stat); + add_env_function ("POSIX.FileSys.ST.isdir", isdir); + add_env_function ("POSIX.FileSys.mkdir", mkdir); + add_env_function ("system os unix open", open_); + add_env_function ("system os unix o_rdonly", o_rdonly); + add_env_function ("system os unix o_wronly", o_wronly); + add_env_function ("system os unix o_append", o_append); + add_env_function ("system os unix o_creat", o_creat); + add_env_function ("system os unix o_trunc", o_trunc); + add_env_function ("OS.FileSys.fullPath", OS.FileSys.fullPath); + add_env_function ("POSIX.FileSys.getcwd", Posix.FileSys.getcwd); + add_env_function ("POSIX.FileSys.access", Posix.FileSys.access); + add_env_function ("POSIX.FileSys.unlink", Posix.FileSys.unlink); + add_env_function ("Time.toReal", MLWTime.toReal); + add_env_function ("Time.fromReal", MLWTime.fromReal); + add_env_function ("Time.-", MLWTime.-); + add_env_function ("Time.+", MLWTime.+); + add_env_function ("real split", Real.split) + ) + + exception UnimplementedEnv of string + fun unimplemented name = + (TextIO.output (TextIO.stdOut, "unimplemented env function: " + ^ name ^ "\n"); + raise UnimplementedEnv name) + +in +fun nj_environment name = + let + fun trap _ = unimplemented ("Environment function " ^ name) + fun lookup [] = tcast trap + | lookup ((name', f)::rest) = + if name' = name then f else lookup rest + in + TextIO.print ("D: nj_environment lookup: " ^ name ^ "\n"); + lookup (!env_refs) + end +end diff --git a/src/make/smlnj-boot.sml b/src/make/smlnj-boot.sml new file mode 100644 index 00000000..b2b200ac --- /dev/null +++ b/src/make/smlnj-boot.sml @@ -0,0 +1,32 @@ +(* this code is used to load the MLWorks compiler into SML/NJ + 1. loads the emulation layer + 2. loads the dummy_make system + 3. loads the batch compiler + 4. dumps an image (for debugging) + 5. compiles pervasives + 6. compiles the batch compiler with itself + *) + +(* SML/NJ's backtrace feature is sometimes useful, but it causes a + noticable slowdown both at runtime and compile time. +CM.make "$smlnj-tdp/back-trace.cm"; +SMLofNJ.Internals.TDP.mode := true; +*) + +use "make/nj_env.sml"; (* Simulate the runtime environment *) +use "make/change_nj.sml"; + +use "make/dummy_make.sml"; +make "../main/__batch.sml"; + +print ("dumping image to make/smlnj-batch.img ...\n"); +SMLofNJ.exportML "make/smlnj-batch.img"; + +Batch_.obey ["-verbose", "-pervasive-dir", "pervasive/", "-compile-pervasive"]; + +Batch_.obey ["-verbose", + "-pervasive-dir", "pervasive/", + "-project", "batch.mlp", + "-configuration", "I386/Linux", + "-target", "__batch.sml", + "-build"]; diff --git a/src/match/_type_utils.sml b/src/match/_type_utils.sml index 4742fd6b..152ea9a1 100644 --- a/src/match/_type_utils.sml +++ b/src/match/_type_utils.sml @@ -169,8 +169,8 @@ functor TypeUtils( val vcc_fun = is_vcc o type_from_scheme val null_fun = not o vcc_fun - val null_exists = NewMap.exists (null_fun o #2) - val vcc_exists = NewMap.exists (vcc_fun o #2) + fun null_exists map = NewMap.exists (null_fun o #2) map + fun vcc_exists map = NewMap.exists (vcc_fun o #2) map val vcc_len = Lists.filter_length vcc_fun val null_len = Lists.filter_length null_fun diff --git a/src/mir/_mir_cg.sml b/src/mir/_mir_cg.sml index b6be255b..3f56311c 100644 --- a/src/mir/_mir_cg.sml +++ b/src/mir/_mir_cg.sml @@ -1284,7 +1284,8 @@ struct | count_gc_tags(AugLambda.SCON_TAG(Ident.STRING _, _)) = 1 | count_gc_tags _ = 0 - val empty_string_tree = NewMap.empty ((op<):string*string->bool,op= : string * string -> bool) + val empty_string_tree : (string, LambdaTypes.LVar) NewMap.map = + NewMap.empty ((op<):string*string->bool,op= : string * string -> bool) fun last [] = Crash.impossible"Last empty list" | last [x] = x @@ -1404,9 +1405,9 @@ struct assign (args,regs,[]) end in - val assign_caller_regs = assign_regs caller_arg_regs - val assign_callee_regs = assign_regs callee_arg_regs - val assign_fp_regs = assign_regs MirRegisters.fp_arg_regs + fun assign_caller_regs args = assign_regs caller_arg_regs args + fun assign_callee_regs args = assign_regs callee_arg_regs args + fun assign_fp_regs args = assign_regs MirRegisters.fp_arg_regs args end fun make_get_args_code (args,copies) = diff --git a/src/mir/_mir_utils.sml b/src/mir/_mir_utils.sml index 4e891025..57750f56 100644 --- a/src/mir/_mir_utils.sml +++ b/src/mir/_mir_utils.sml @@ -1227,9 +1227,9 @@ struct assign (args,regs,[]) end in - val assign_caller_regs = assign_regs caller_arg_regs - val assign_tail_regs = assign_regs tail_arg_regs - val assign_fp_regs = assign_regs MirRegisters.fp_arg_regs + fun assign_caller_regs args = assign_regs caller_arg_regs args + fun assign_tail_regs args = assign_regs tail_arg_regs args + fun assign_fp_regs args = assign_regs MirRegisters.fp_arg_regs args end fun do_app(debugger_information, diff --git a/src/mir/_mirregisters.sml b/src/mir/_mirregisters.sml index e40d1fb1..7d5424e4 100644 --- a/src/mir/_mirregisters.sml +++ b/src/mir/_mirregisters.sml @@ -301,8 +301,13 @@ functor MirRegisters( (* These association lists define the real registers onto which the *) (* special purpose registers will map. *) - - val special_assignments = + local + type alist = (int * MachSpec.register) list + type special_assignments = {gc : alist, + non_gc : alist, + fp : alist} + in + val special_assignments : special_assignments = let val callers = Lists.zip (caller_arg_regs, MachSpec.caller_arg_regs) val callees = Lists.zip (callee_arg_regs, MachSpec.callee_arg_regs) @@ -322,6 +327,7 @@ functor MirRegisters( non_gc = [], fp = Lists.zip (fp_global :: fp_arg_regs, MachSpec.fp_global :: MachSpec.fp_arg_regs)} end + end (* === REAL REGISTER ASSIGNMENTS === *) diff --git a/src/parser/_actionfunctions.sml b/src/parser/_actionfunctions.sml index d9b3b4f0..0febfde8 100755 --- a/src/parser/_actionfunctions.sml +++ b/src/parser/_actionfunctions.sml @@ -1118,24 +1118,29 @@ fun check_empty_tyvars (opts,tyvars) = local - fun check_disjoint_tycons (key,message)(opts,item,list) = - if member(fn (x,y) => Ident.tycon_eq(key x,key y))(item,list) + fun check_disjoint_tycons (key: 'a -> Ident.TyCon, message:string) + (opts, item:'a, list:'a list) = + if member(fn (x,y) => Ident.tycon_eq(key x,key y))(item,list) then - let val Ident.TYCON sym = key item - in - error (opts,"Multiple declaration of type constructor " ^ - Symbol.symbol_name sym ^ " in " ^ message) - end - else () + let val Ident.TYCON sym = key item + in + error (opts,"Multiple declaration of type constructor " ^ + Symbol.symbol_name sym ^ " in " ^ message) + end + else () in - val check_disjoint_datbind = check_disjoint_tycons - (fn (_,x,_,_,_) => x, "datatype binding") - val check_disjoint_typbind = check_disjoint_tycons - (fn (_,x,_,_) => x, "type binding") - val check_disjoint_datdesc = check_disjoint_tycons - (fn (_,x,_) => x, "datatype specification") - val check_disjoint_typdesc = check_disjoint_tycons - (fn (_,x,_) => x, "type specification") +fun check_disjoint_datbind (opts, item, list) = + check_disjoint_tycons (fn (_,x,_,_,_) => x, "datatype binding") + (opts, item, list) +fun check_disjoint_typbind (opts, item, list) = + check_disjoint_tycons (fn (_,x,_,_) => x, "type binding") + (opts, item, list) +fun check_disjoint_datdesc (opts, item, list) = + check_disjoint_tycons (fn (_,x,_) => x, "datatype specification") + (opts, item, list) +fun check_disjoint_typdesc (opts, item, list) = + check_disjoint_tycons (fn (_,x,_) => x, "type specification") + (opts, item, list) end (* need to ensure that all bindings in a rec are of form *) diff --git a/src/pervasive/array.sml b/src/pervasive/array.sml new file mode 100644 index 00000000..b1072f44 --- /dev/null +++ b/src/pervasive/array.sml @@ -0,0 +1,86 @@ +(* + * The arrays module. + * + * Copyright (c) 1992 Harlequin Ltd. + * + * $Log: array.sml,v $ + * Revision 1.6 1996/05/21 11:48:15 matthew + * Removing Copy exception, (replacing with Subscript) + * + * Revision 1.5 1993/02/25 18:13:17 matthew + * Removed Array.T from signature + * + * Revision 1.4 1992/12/21 12:41:04 daveb + * Added the agreed 'Array' structure. Renamed the existing Array structure + * to ExtendedArray. + * + * Revision 1.3 1992/08/25 13:51:36 richard + * Strengthened the types of all values for which it was possible. + * Added tabulate. + * + * Revision 1.2 1992/08/20 12:24:43 richard + * Enriched the ARRAY signature. + * + * Revision 1.1 1992/08/07 10:17:13 davidt + * Initial revision + * + * + *) + +signature ARRAY = + sig + eqtype 'a array +(* + eqtype 'a T + sharing type T = array +*) + exception Size + exception Subscript + val array: int * '_a -> '_a array + val arrayoflist: '_a list -> '_a array + val tabulate: int * (int -> '_a) -> '_a array + val sub: 'a array * int -> 'a + val update: 'a array * int * 'a -> unit + val length: 'a array -> int + end + +signature EXTENDED_ARRAY = + sig + (* include "ARRAY" -- omitted to keep SML/NJ happy. *) + eqtype 'a array +(* + eqtype 'a T + sharing type T = array +*) + exception Size + exception Subscript + exception Find + + val array : int * '_a -> '_a array + val length : 'a array -> int + val update : 'a array * int * 'a -> unit + val sub : 'a array * int -> 'a + val arrayoflist : '_a list -> '_a array + val tabulate : int * (int -> '_a) -> '_a array + + val from_list : '_a list -> '_a array + val to_list : 'a array -> 'a list + val fill : 'a array * 'a -> unit + val map : ('a -> '_b) -> 'a array -> '_b array + val map_index : (int * 'a -> '_b) -> 'a array -> '_b array + val iterate : ('a -> unit) -> 'a array -> unit + val iterate_index : (int * 'a -> unit) -> 'a array -> unit + val rev : '_a array -> '_a array + val duplicate : '_a array -> '_a array + val subarray : '_a array * int * int -> '_a array + val append : '_a array * '_a array -> '_a array + val reducel : ('a * 'b -> 'a) -> ('a * 'b array) -> 'a + val reducer : ('a * 'b -> 'b) -> ('a array * 'b) -> 'b + val reducel_index : (int * 'a * 'b -> 'a) -> ('a * 'b array) -> 'a + val reducer_index : (int * 'a * 'b -> 'b) -> ('a array * 'b) -> 'b + val copy : 'a array * int * int * 'a array * int -> unit + val fill_range : 'a array * int * int * 'a -> unit + val find : ('a -> bool) -> 'a array -> int + val find_default : (('a -> bool) * int) -> 'a array -> int + val maxLen : int + end; diff --git a/src/pervasive/bits.sml b/src/pervasive/bits.sml new file mode 100644 index 00000000..a3189ec6 --- /dev/null +++ b/src/pervasive/bits.sml @@ -0,0 +1,22 @@ +(* ==== PERVASIVE BITS SIGNATURE ==== + * + * Copyright (C) 1992 Harlequin Ltd. + * + * Revision Log + * ------------ + * $Log: bits.sml,v $ + * Revision 1.1 1992/08/25 08:09:51 richard + * Initial revision + * + *) + +signature BITS = + sig + val andb : int * int -> int + val orb : int * int -> int + val xorb : int * int -> int + val lshift : int * int -> int + val rshift : int * int -> int + val arshift : int * int -> int + val notb : int -> int + end; diff --git a/src/pervasive/bytearray.sml b/src/pervasive/bytearray.sml new file mode 100644 index 00000000..046564dc --- /dev/null +++ b/src/pervasive/bytearray.sml @@ -0,0 +1,67 @@ +(* ==== PERVASIVE BYTEARRAY STRUCTURE ==== + * + * Copyright (C) 1992 Harlequin Ltd. + * + * Description + * ----------- + * Byte arrays are mutable objects which resemble arrays by may only + * contain integers in the range [0, 255]. + * + * Revision Log + * ------------ + * $Log: bytearray.sml,v $ + * Revision 1.4 1996/05/21 11:47:55 matthew + * Removing Copy exception, (replacing with Subscript) + * + * Revision 1.3 1993/03/24 17:28:49 jont + * Added Find to list of visible exceptions + * + * Revision 1.2 1993/02/25 18:17:01 matthew + * Remove ByteArray.T from signature + * + * Revision 1.1 1992/08/24 10:29:04 richard + * Initial revision + * + *) + +signature BYTEARRAY = + sig + eqtype bytearray + + exception Range of int + exception Size + exception Subscript + exception Substring + exception Find + + val array : int * int -> bytearray + val length : bytearray -> int + val update : bytearray * int * int -> unit + val sub : bytearray * int -> int + val arrayoflist : int list -> bytearray + + val tabulate : int * (int -> int) -> bytearray + val from_list : int list -> bytearray + val to_list : bytearray -> int list + val from_string : string -> bytearray + val to_string : bytearray -> string + val fill : bytearray * int -> unit + val map : (int -> int) -> bytearray -> bytearray + val map_index : (int * int -> int) -> bytearray -> bytearray + val iterate : (int -> unit) -> bytearray -> unit + val iterate_index : (int * int -> unit) -> bytearray -> unit + val rev : bytearray -> bytearray + val duplicate : bytearray -> bytearray + val subarray : bytearray * int * int -> bytearray + val substring : bytearray * int * int -> string + val append : bytearray * bytearray -> bytearray + val reducel : ('a * int -> 'a) -> ('a * bytearray) -> 'a + val reducer : (int * 'a -> 'a) -> (bytearray * 'a) -> 'a + val reducel_index : (int * 'a * int -> 'a) -> ('a * bytearray) -> 'a + val reducer_index : (int * int * 'a -> 'a) -> (bytearray * 'a) -> 'a + val copy : bytearray * int * int * bytearray * int -> unit + val fill_range : bytearray * int * int * int -> unit + val find : (int -> bool) -> bytearray -> int + val find_default : ((int -> bool) * int) -> bytearray -> int + val maxLen : int + end; diff --git a/src/pervasive/floatarray.sml b/src/pervasive/floatarray.sml new file mode 100644 index 00000000..aab1bf57 --- /dev/null +++ b/src/pervasive/floatarray.sml @@ -0,0 +1,59 @@ +(* ==== PERVASIVE FLOATARRAY STRUCTURE ==== + * + * Copyright (C) 1996 Harlequin Ltd. + * + * Description + * ----------- + * Float arrays are mutable objects which differ from arrays of floats + * in that the entries are not individually boxed. + * + * + * Revision Log + * ------------ + * $Log: floatarray.sml,v $ + * Revision 1.1 1997/01/07 12:44:38 andreww + * new unit + * [Bug #1818] + * Signature for the new pervasive FloatArray structure + * + * + *) + +signature FLOATARRAY = + sig + eqtype floatarray + + exception Range of int + exception Size + exception Subscript + exception Find + + val array : int * real -> floatarray + val length : floatarray -> int + val update : floatarray * int * real -> unit + val sub : floatarray * int -> real + val arrayoflist : real list -> floatarray + + val tabulate : int * (int -> real) -> floatarray + val from_list : real list -> floatarray + val to_list : floatarray -> real list + val fill : floatarray * real -> unit + val map : (real -> real) -> floatarray -> floatarray + val map_index : (int * real -> real) -> floatarray -> floatarray + val iterate : (real -> unit) -> floatarray -> unit + val iterate_index : (int * real -> unit) -> floatarray -> unit + val rev : floatarray -> floatarray + val duplicate : floatarray -> floatarray + val subarray : floatarray * int * int -> floatarray + val append : floatarray * floatarray -> floatarray + val reducel : ('a * real -> 'a) -> ('a * floatarray) -> 'a + val reducer : (real * 'a -> 'a) -> (floatarray * 'a) -> 'a + val reducel_index : (int * 'a * real -> 'a) -> ('a * floatarray) -> 'a + val reducer_index : (int * real * 'a -> 'a) -> (floatarray * 'a) -> 'a + val copy : floatarray * int * int * floatarray * int -> unit + val fill_range : floatarray * int * int * real -> unit + val find : (real -> bool) -> floatarray -> int + val find_default : ((real -> bool) * int) -> floatarray -> int + val maxLen : int + end; + diff --git a/src/pervasive/general.sml b/src/pervasive/general.sml new file mode 100755 index 00000000..26803c7b --- /dev/null +++ b/src/pervasive/general.sml @@ -0,0 +1,84 @@ +(* ==== INITIAL BASIS : GENERAL ==== + * + * Copyright (C) 1995 Harlequin Ltd. + * + * Description + * ----------- + * This is part of the extended Initial Basis. + * + * Revision Log + * ------------ + * $Log: general.sml,v $ + * Revision 1.4 1997/08/04 12:43:59 brucem + * [Bug #30084] + * Remove items which have been moved to Option. + * And delete the stub structure which previously declared datatype option. + * + * Revision 1.3 1997/05/01 11:48:58 jont + * [Bug #30088] + * Get rid of MLWorks.Option + * + * Revision 1.2 1996/07/11 10:22:43 andreww + * Adding exception Empty. + * + * Revision 1.1 1996/06/25 09:56:42 andreww + * new unit + * Addition to the pervasive library. + * + * Revision 1.3 1996/05/08 14:53:41 jont + * Update to latest revision + * + * Revision 1.2 1996/04/23 13:05:43 matthew + * Updating + * + * Revision 1.1 1996/04/18 11:42:57 jont + * new unit + * + * Revision 1.4 1996/03/28 12:29:02 matthew + * Fixing rigid type sharing problem + * + * Revision 1.3 1995/03/31 13:44:07 brianm + * Adding options operators to General ... + * + * Revision 1.2 1995/03/12 18:49:24 brianm + * Commented out troublesome datatypes and equality definitions. + * + * Revision 1.1 1995/03/08 16:23:04 brianm + * new unit + * + *) + +signature GENERAL = + sig + eqtype unit + type exn + + exception Bind + exception Match + exception Subscript + exception Size + exception Overflow + exception Domain + exception Div + exception Chr + exception Fail of string + exception Empty + + val exnName : exn -> string + val exnMessage : exn -> string + + datatype order = LESS | EQUAL | GREATER + + val <> : (''a * ''a) -> bool + + val ! : 'a ref -> 'a + + val := : ('a ref * 'a) -> unit + + val o : (('b -> 'c) * ('a -> 'b)) -> 'a -> 'c + + val before : ('a * unit) -> 'a + + val ignore : 'a -> unit + + end diff --git a/src/pervasive/mlworks.sml b/src/pervasive/mlworks.sml new file mode 100644 index 00000000..e83448d7 --- /dev/null +++ b/src/pervasive/mlworks.sml @@ -0,0 +1,1039 @@ +(* ==== PERVASIVE MLWORKS LIBRARY ==== + * + * Copyright (C) 1991 Harlequin Ltd. + * + * Revision Log + * ------------ + * $Log: mlworks.sml,v $ + * Revision 1.148 1998/05/26 13:56:24 mitchell + * [Bug #30413] + * Move Exit structure to pervasives + * + * Revision 1.147 1998/03/26 16:21:00 jont + * [Bug #30090] + * Remove MLWorks.IO + * + * Revision 1.146 1998/03/26 14:08:42 jont + * [Bug #30090] + * Remove all of MLWorks.IO + * + * Revision 1.145 1998/02/10 15:31:30 jont + * [Bug #70065] + * Remove uses of MLWorks.IO.messages and use the Messages structure + * + * Revision 1.144 1997/11/26 15:45:22 johnh + * [Bug #30134] + * Change meaning of third arg of deliver and convert to datatype. + * + * Revision 1.143 1997/11/09 19:14:52 jont + * [Bug #30089] + * Furhter work on getting rid of MLWorks.Time + * Also removing {set_,}file_modified + * + * Revision 1.142 1997/10/09 13:45:35 jont + * [Bug #30204] + * Add comment indicating restrictions on use of update_exn + * + * Revision 1.141 1997/10/08 17:23:28 jont + * [Bug #30204] + * Add update_exn and update_exn_cons + * + * Revision 1.140 1997/10/07 14:45:19 johnh + * [Bug #30226] + * Add exitFn for storing the function to call when the exe exits normally. + * + * Revision 1.139 1997/08/04 10:37:27 brucem + * [Bug #30084] + * Add datatype MLWorks.Internal.Types.option. + * Change all occurences of General.option to the new option. + * + * Revision 1.138 1997/06/17 13:50:58 andreww + * [Bug #20014] + * adding MLWorks.name + * + * Revision 1.137 1997/06/12 11:59:49 matthew + * [Bug #30101] + * + * Adding sin and cos + * + * Revision 1.136 1997/06/12 10:09:57 matthew + * Adding print_error to StandardIO + * + * Revision 1.135 1997/05/28 21:08:46 jont + * [Bug #30076] + * Modifications to allow stack based parameter passing on the I386 + * + * Revision 1.134 1997/05/09 13:39:40 jont + * [Bug #30091] + * Remove MLWorks.Internal.FileIO and related stuff + * + * Revision 1.133 1997/05/01 11:44:14 jont + * [Bug #30088] + * Get rid of MLWorks.Option + * + * Revision 1.132 1997/03/25 11:46:48 andreww + * [Bug #1989] + * removing Internal.Value.exn_name_string. + * + * Revision 1.131 1997/03/18 11:16:10 andreww + * [Bug #1431] + * Adding Io exception from basis to Internal Value so that + * general exnMessage prints it nicely. + * + * Revision 1.130 1997/03/07 15:59:34 andreww + * [Bug #1677] + * Adding hook for stopping preemption. This is used to keep + * the GUI listener operating correctly --- when the user types + * "stop pre-empting", the listener must claim its access mutex + * before actually stopping, otherwise it will go to sleep,and + * a concurrent thread will continue executing. + * + * Revision 1.129 1997/03/03 11:13:53 matthew + * Adding unsafe floatarray operations to Internal.Value + * + * Revision 1.128 1997/01/27 11:07:34 andreww + * [Bug #1891] + * Adding critical section primitives for threads. + * + * Revision 1.127 1997/01/06 15:55:13 andreww + * [Bug #1818] + * Adding new FloatArray primitives. + * + * Revision 1.126 1996/11/18 10:27:44 matthew + * Adding real equality builtin to MLWorks.Internal.Value. + * + * Revision 1.125 1996/10/21 14:42:28 andreww + * [Bug #1682] + * removing MLWorks.General + * + * Revision 1.124 1996/10/21 10:34:38 andreww + * [Bug #1666] + * Adding Threads exception to MLWorks.Threads + * + * Revision 1.123 1996/09/18 14:10:18 io + * [Bug #1490] + * update String maxSize + * + * Revision 1.122 1996/08/21 09:00:38 stephenb + * [Bug #1554] + * Introduce MLWorks.Internal.IO as a repository for file_desc + * and the read, write, seek, ... etc. stuff. + * + * Revision 1.121 1996/07/16 15:48:15 andreww + * Incorporated gui_standard_io signature. + * + * Revision 1.120 1996/07/15 12:42:05 andreww + * Adding exception Empty. + * + * Revision 1.119 1996/06/25 10:52:03 andreww + * adding General to the top level. + * + * Revision 1.118 1996/06/19 13:42:40 nickb + * Extend datatype MLWorks.Internal.Trace.status. + * + * Revision 1.117 1996/05/30 11:50:53 daveb + * Revising top level for revised basis. + * + * Revision 1.116 1996/05/29 12:33:31 matthew + * Fixing problem with SysErr + * + * Revision 1.115 1996/05/28 11:58:32 daveb + * Removed MLWorks.RawIO. + * + * Revision 1.114 1996/05/22 13:20:01 matthew + * Changing type of real_to_string + * + * Revision 1.113 1996/05/20 10:00:06 matthew + * Changing type of word32 shift operations + * + * Revision 1.112 1996/05/17 10:05:18 matthew + * Moving Bits to Internal + * + * Revision 1.111 1996/05/16 13:18:56 stephenb + * MLWorks.Debugger: moved to MLWorks.Internal.Debugger + * MLWorks.OS.arguments: moved MLWorks.arguments & removed MLWorks.OS + * + * Revision 1.109 1996/05/07 10:22:14 jont + * Array moving to MLWorks.Array + * + * Revision 1.108 1996/05/03 12:27:52 nickb + * Add image delivery hooks. + * + * Revision 1.107 1996/04/29 14:49:44 matthew + * Removing Real structure + * + * Revision 1.106 1996/04/29 10:47:47 jont + * Modifications to deliver and save + * + * Revision 1.105 1996/04/19 16:13:05 stephenb + * Put MLWorks.exit back to enable boostrapping from older compilers. + * + * Revision 1.104 1996/04/17 11:02:35 stephenb + * Remove exit, terminate, atExit and most of the OS structure since + * they are no longer needed now that OS.Process has been updated. + * + * Revision 1.103 1996/03/28 11:34:37 matthew + * Language revisions + * + * Revision 1.102 1996/03/20 12:19:32 matthew + * Changing the type of some things + * + * Revision 1.101 1996/03/08 11:42:18 daveb + * Changed MLWorks.Internal.Dynamic types to new identifier convention. + * + * Revision 1.100 1996/02/22 13:15:06 daveb + * Moved MLWorks.Dynamic to MLWorks.Internal.Dynamic. Hid some members; moved + * some functionality to the Shell structure. + * + * Revision 1.99 1996/02/16 15:00:34 nickb + * "fn_save" becomes "deliver". + * + * Revision 1.98 1996/01/22 11:01:32 matthew + * Simplifying treatment of pervasive exceptions + * + * Revision 1.97 1996/01/17 16:05:58 stephenb + * OS reorganisation: remove the Unix and NT code as it is going elsewhere. + * + * Revision 1.96 1996/01/16 12:22:05 nickb + * Change to GC interface. + * + * Revision 1.95 1996/01/15 16:18:20 matthew + * Adding NT directory operations + * + * Revision 1.94 1996/01/15 11:47:45 nickb + * Add thread sleep and wake operations. + * + * Revision 1.93 1996/01/12 10:33:22 stephenb + * Add MLWORKS.Threads.Internal.reset_signal_status + * + * Revision 1.92 1996/01/08 14:18:00 nickb + * Remove signal reservation. + * + * Revision 1.91 1995/12/04 15:55:59 daveb + * pervasive module names now begin with a space. + * + * Revision 1.90 1995/11/21 11:22:13 jont + * Add Frame.frame_double for accessing directly spilled reals + * + * Revision 1.89 1995/10/17 12:51:59 jont + * Add exec_save for saving executables + * + * Revision 1.88 1995/09/13 14:23:26 jont + * Add function save to MLWorks for use by exportFn + * + * Revision 1.87 1995/09/12 15:08:33 daveb + * Added types for different sizes of words and integers. + * + * Revision 1.85 1995/07/26 14:15:01 jont + * Add makestring to word signature and structure + * + * Revision 1.84 1995/07/24 14:20:42 jont + * Add Words signature and structure + * + * Revision 1.83 1995/07/20 17:01:30 jont + * Add Overflow to structure Exception + * + * Revision 1.82 1995/07/19 15:09:52 nickb + * Two constructors called MLWorks.Profile.Profile. + * + * Revision 1.81 1995/07/19 13:51:55 nickb + * Whoops; major type screwups in new profiler. + * + * Revision 1.80 1995/07/17 16:33:47 nickb + * Change to profiler interface. + * + * Revision 1.79 1995/07/17 11:13:21 jont + * Add hex integer printing facilities + * + * Revision 1.78 1995/06/02 14:02:36 nickb + * Change threads restart system. + * + * Revision 1.77 1995/05/22 15:45:37 nickb + * Add threads interface + * + * Revision 1.76 1995/05/10 17:51:49 daveb + * Changed argument of Unix exception from int to string. + * Added OS.Unix.{stat,seek,set_block_mode,can_input}. + * + * Revision 1.75 1995/05/02 13:12:39 matthew + * Adding CAST and UMAP primitives + * + * Revision 1.74 1995/04/13 14:03:24 jont + * Add terminate, atExit functions + * + * Revision 1.73 1995/03/01 11:24:16 matthew + * Unifying Value.Frame and Frame.pointer + * + * Revision 1.72 1995/01/12 15:23:07 jont + * Add Win_nt.get_current_directory + * + * Revision 1.71 1994/12/09 14:38:44 jont + * Add OS.Win_nt structure + * + * Revision 1.70 1994/11/24 16:19:45 matthew + * Adding new "unsafe" pervasives + * + * Revision 1.69 1994/09/28 14:45:11 matthew + * Added pervasive Option structure + * + * Revision 1.68 1994/08/24 16:31:57 matthew + * Adding unsafe array operations + * + * Revision 1.67 1994/07/22 15:37:35 jont + * Modify for new code_module + * + * Revision 1.66 1994/07/22 15:26:24 jont + * Modify for new code_module + * + * Revision 1.65 1994/07/08 10:08:54 nickh + * Add event functions for stack overflow and interrupt handlers. + * + * Revision 1.64 1994/06/29 14:58:56 nickh + * Add MLWorks messages stream. + * + * Revision 1.63 1994/06/22 15:27:30 nickh + * Add Trace.restore_all. + * + * Revision 1.62 1994/06/09 15:37:46 nickh + * Updated runtime signal handling. + * + * Revision 1.61 1994/06/06 11:46:19 nosa + * Breakpoint settings on function exits. + * + * Revision 1.60 1994/03/30 14:46:24 daveb + * Revised MLWorks.IO.set_modified_file to take a datatype. + * + * Revision 1.59 1994/03/30 13:55:51 daveb + * Removed input_string and output_string. + * + * Revision 1.58 1994/03/30 13:22:12 daveb + * Added MLWorks.IO.set_file_modified. + * + * Revision 1.57 1994/02/23 17:04:26 nosa + * Step and breakpoints Debugger. + * + * Revision 1.56 1994/02/08 14:37:21 matthew + * Added realpath function + * + * Revision 1.55 1993/11/25 13:00:45 jont + * Reinstated missing version 1.53 + * + * Revision 1.54 1993/11/22 14:28:13 jont + * Changed type of modules to include a time stamp field + * + * Revision 1.53 1993/11/18 12:05:51 nickh + * Add to IO and RawIO to provide closed_in and closed_out functions, which + * test a stream for closed-ness. + * + * Revision 1.52 1993/11/15 16:44:26 nickh + * New, more versatile time structure. + * + * Revision 1.51 1993/08/27 19:34:57 daveb + * Added MLworks.OS.Unix.{unlink,rmdir,mkdir}. + * + * Revision 1.50 1993/08/26 11:13:00 richard + * Removed the X exception. It's now in the Motif interface code. + * + * Revision 1.49 1993/08/25 14:01:37 richard + * Changed MLWorks.OS.Unix.vfork_* to return the pid of the forked + * process. Added MLWorks.OS.Unix.kill. + * + * Revision 1.48 1993/08/18 12:53:36 daveb + * Added X exception. + * + * Revision 1.47 1993/08/10 11:28:49 daveb + * Removed "../pervasive" from require statements, for the new make systems. + * + * Revision 1.46 1993/07/23 11:08:17 richard + * Added system calls to read directories and the password file. + * + * Revision 1.45 1993/07/19 13:53:26 nosa + * Added two frame functions for debugger + * + * Revision 1.44 1993/06/09 16:06:35 matthew + * Added text_preprocess hook + * + * Revision 1.43 1993/05/05 17:09:17 jont + * Added MLWorks.OS.Unix.password_file to get the association list of user names + * to home directories necessary for translating ~ + * + * Revision 1.42 1993/04/23 14:56:28 jont + * Added Integer and Real substructures of MLWorks with makestring and print functions + * + * Revision 1.41 1993/04/21 15:58:26 richard + * Removed defunct Editor interface and added sytem calls to enable + * its replacement. + * + * Revision 1.40 1993/04/20 13:52:57 richard + * Added more Unix system call interfaces. + * New Trace structure to go with runtime implementation. + * + * Revision 1.39 1993/04/13 09:50:58 matthew + * Moved dynamic stuff from MLWorks.Internal.Typerep to MLWorks.Dynamic + * Moved break stuff from MLWorks.Internal.Tracing to MLWorks.Debugger + * + * Revision 1.38 1993/04/08 17:29:01 jont + * Expose vi_file and emacs_file + * + * Revision 1.37 1993/04/02 14:47:39 jont + * Extended images structure to include table of contents reading + * + * Revision 1.36 1993/03/26 15:52:31 matthew + * Added break function to Tracing substructure + * + * Revision 1.35 1993/03/23 18:29:31 jont + * Added vector primitives + * + * Revision 1.34 1993/03/18 16:34:45 jont + * Changed the specification of load_codeset to reflect changes in machtypes + * + * Revision 1.33 1993/03/11 18:36:55 jont + * Added Intermal. Images including save and clean. + * Added other_operation to Editor for arbitrary bits of emacs lisp + * + * Revision 1.32 1993/03/10 16:40:47 jont + * Added Editor substructure to MLWorks + * + * Revision 1.31 1993/02/26 11:13:05 nosa + * Implemented a multi-level profiler + * + * Revision 1.30 1993/02/25 18:17:57 matthew + * Changed ByteArray.T to ByteArray.bytearray + * + * Revision 1.29 1993/02/18 16:33:36 matthew + * Added TypeRep substructure + * + * Revision 1.28 1993/02/09 14:58:38 jont + * Changes for code vector reform. + * + * Revision 1.27 1993/01/14 14:45:50 daveb + * Added objectfile version argument to load_wordset, to catch an interpreter + * trying to load inconsistent code. + * + * Revision 1.26 1993/01/05 16:52:41 richard + * Added extra exceptions to those passed to the runtime system. + * + * Revision 1.25 1992/12/22 11:43:12 jont + * Removed pervasive vector + * + * Revision 1.24 1992/12/21 11:29:53 daveb + * Added support for the 'agreed' Array and Vector structures. + * Renamed the old Array to ExtendedArray. + * + * Revision 1.23 1992/11/30 18:51:17 matthew + * Tidied up IO signature + * + * Revision 1.22 1992/11/30 17:56:05 matthew + * Added representation of streams as records. Old IO is now RawIO. + * + * Revision 1.21 1992/11/12 17:22:21 clive + * Added tracing hooks to the runtime system + * + * Revision 1.20 1992/11/10 13:13:37 richard + * Added StorageManager exception and changed the type of the + * StorageManager interface function. + * + * Revision 1.19 1992/10/29 17:07:45 richard + * Removed debugger structure and added time and event structures. + * + * Revision 1.18 1992/10/06 17:20:26 clive + * Type of call_debugger has changed to take debugger function as well + * as exception + * + * Revision 1.17 1992/09/25 14:20:56 matthew + * Added Internal.string_to_real + * + * Revision 1.16 1992/09/23 16:12:32 daveb + * Added clear_eof function to IO. + * + * Revision 1.15 1992/09/01 13:44:40 richard + * Changed the types of the OS information stuff. Added real_to_string, + * arguments, Prod and Value. + * + * Revision 1.14 1992/08/28 10:32:51 clive + * Added get_code_object_debug_info + * + * Revision 1.13 1992/08/28 08:21:53 richard + * Changed call to environment so that it isn't preserved across + * images. + * Added floating point exceptions. + * + * Revision 1.12 1992/08/26 14:14:16 richard + * Rationalisation of the MLWorks structure. + * + * Revision 1.11 1992/08/25 08:37:30 richard + * Copied BITS signature to a separate file. + * Added ByteArray structure. + * + * Revision 1.10 1992/08/20 12:54:36 richard + * Corrected paths to string and array in requires. + * + * Revision 1.9 1992/08/20 12:24:43 richard + * Added extra unsafe value utilities. + * + * Revision 1.8 1992/08/18 16:38:55 richard + * Corrected type of input_string. + * + * Revision 1.7 1992/08/18 15:36:27 richard + * Added more input and output functions for different types. + * Added Value structure for opaque value stuff and removed + * duplicates elsewhere. + * + * Revision 1.6 1992/08/17 10:58:26 richard + * Added MLWorks.System.Runtime.GC.interface. + * + * Revision 1.5 1992/08/15 17:30:02 davidt + * Put in IO.input_line function. + * + * Revision 1.4 1992/08/13 11:40:16 clive + * Added a function to get header information from an ml_object + * + * Revision 1.3 1992/08/11 15:33:23 clive + * Work on tracing + * + * Revision 1.2 1992/08/10 15:26:35 richard + * Added load_wordset to interpreter structure. + * + * Revision 1.1 1992/08/10 12:18:46 davidt + * Initial revision + * + *) + +require " array"; +require " vector"; +require " bytearray"; +require " floatarray"; +require " string"; +require " bits"; +require " general"; + +signature MLWORKS = + sig + + structure String : STRING + + exception Interrupt + + structure Deliver : + sig + datatype app_style = CONSOLE | WINDOWS + type deliverer = string * (unit -> unit) * app_style -> unit + type delivery_hook = deliverer -> deliverer + val deliver : deliverer + val with_delivery_hook : delivery_hook -> ('a -> 'b) -> 'a -> 'b + val add_delivery_hook : delivery_hook -> unit + val exitFn : (unit -> unit) ref + end + + val arguments : unit -> string list + val name: unit -> string + + structure Threads : + sig + type 'a thread + exception Threads of string + + val fork : ('a -> 'b) -> 'a -> 'b thread + val yield : unit -> unit + + datatype 'a result = + Running (* still running *) + | Waiting (* waiting *) + | Sleeping (* sleeping *) + | Result of 'a (* completed, with this result *) + | Exception of exn (* exited with this uncaught exn *) + | Died (* died (e.g. bus error) *) + | Killed (* killed *) + | Expired (* no longer exists (from a previous image) *) + + val result : 'a thread -> 'a result + + val sleep : 'a thread -> unit + val wake : 'a thread -> unit + + structure Internal : + sig + eqtype thread_id + + val id : unit -> thread_id (* this thread *) + val get_id : 'a thread -> thread_id (* that thread *) + + val children : thread_id -> thread_id list + val parent : thread_id -> thread_id + + val all : unit -> thread_id list (* all threads *) + + val kill : thread_id -> unit (* kill a thread *) + val raise_in : thread_id * exn -> unit (* raise E in the thread *) + val yield_to : thread_id -> unit (* fiddle with scheduling *) + + val state : thread_id -> unit result (* the state of that thread *) + val get_num : thread_id -> int (* the 'thread number' *) + + val set_handler : (int -> unit) -> unit + (* fatal signal handler fn for this thread *) + + val reset_fatal_status : unit -> unit + (* Mark the thread as being outside of a fatal handler *) + + structure Preemption : + sig + val start : unit -> unit + val stop : unit -> unit + val on : unit -> bool + val get_interval : unit -> int (* milliseconds *) + val set_interval : int -> unit + val enter_critical_section: unit -> unit + val exit_critical_section: unit -> unit + val in_critical_section: unit -> bool + end + end + end + + structure Internal : + sig + + exception Save of string + val save : string * (unit -> 'a) -> unit -> 'a + val execSave : string * (unit -> 'a) -> unit -> 'a + val real_to_string : real * int -> string + exception StringToReal + val string_to_real : string -> real + + val text_preprocess : ((int -> string) -> int -> string) ref + + structure Types : + sig + type int8 + type word8 + type int16 + type word16 + type int32 + type word32 + datatype 'a option = SOME of 'a | NONE + datatype time = TIME of int * int * int (* basis time *) + end + + structure Error : + sig + type syserror + exception SysErr of string * syserror Types.option + val errorMsg: syserror -> string + val errorName: syserror -> string + val syserror: string -> syserror Types.option + end + + + structure IO : + sig + exception Io of {cause: exn, name: string, function: string} + + datatype file_desc = FILE_DESC of int + val write : file_desc * string * int * int -> int + val read : file_desc * int -> string + val seek : file_desc * int * int -> int + val close : file_desc -> unit + val can_input : file_desc -> int + end + + + structure StandardIO : + sig + type IOData = {input: {descriptor: IO.file_desc Types.option, + get: int -> string, + get_pos: (unit -> int) Types.option, + set_pos: (int -> unit) Types.option, + can_input: (unit-> bool) Types.option, + close: unit->unit}, + output: {descriptor: IO.file_desc Types.option, + put: {buf:string,i:int,sz:int Types.option} -> int, + get_pos: (unit -> int) Types.option, + set_pos: (int -> unit) Types.option, + can_output: (unit-> bool) Types.option, + close: unit->unit}, + error: {descriptor: IO.file_desc Types.option, + put: {buf:string,i:int,sz:int Types.option} -> int, + get_pos: (unit -> int) Types.option, + set_pos: (int -> unit) Types.option, + can_output: (unit->bool) Types.option, + close: unit-> unit}, + access: (unit->unit)->unit} + + val currentIO: unit -> IOData + val redirectIO: IOData -> unit + val resetIO: unit -> unit + val print : string -> unit + val printError : string -> unit + end + + + structure Images : + sig + exception Table of string + val clean : unit -> unit + val save : string * (unit -> 'a) -> unit -> 'a + val table : string -> string list + end + + structure Bits : BITS + + structure Word32 : + sig + val word32_orb: Types.word32 * Types.word32 -> Types.word32 + val word32_xorb: Types.word32 * Types.word32 -> Types.word32 + val word32_andb: Types.word32 * Types.word32 -> Types.word32 + val word32_notb: Types.word32 -> Types.word32 + val word32_lshift: Types.word32 * word -> Types.word32 + val word32_rshift: Types.word32 * word -> Types.word32 + val word32_arshift: Types.word32 * word -> Types.word32 + end; + + structure Word : + sig + val word_orb: word * word -> word + val word_xorb: word * word -> word + val word_andb: word * word -> word + val word_notb: word -> word + val word_lshift: word * word -> word + val word_rshift: word * word -> word + val word_arshift: word * word -> word + end; + + structure Array : ARRAY + structure ByteArray : BYTEARRAY + structure FloatArray: FLOATARRAY + structure ExtendedArray : EXTENDED_ARRAY + structure Vector : VECTOR + + structure Value : + sig + type ml_value + type T = ml_value + + exception Value of string + + val cast : 'a -> 'b + val ccast : 'a -> 'b + val list_to_tuple : T list -> T + val tuple_to_list : T -> T list + val string_to_real : string -> real + val real_to_string : real -> string + + (* real equality -- needed now real isn't an equality type *) + val real_equal : real * real -> bool + val arctan : real -> real + val cos : real -> real + val exp : real -> real + val sin : real -> real + val sqrt : real -> real + + (* Unchecked arithmetic *) + val unsafe_plus : int * int -> int + val unsafe_minus : int * int -> int + + (* Unchecked structure accessing *) + val unsafe_array_sub : '_a Array.array * int -> '_a + val unsafe_array_update : '_a Array.array * int * '_a -> unit + + val unsafe_bytearray_sub : ByteArray.bytearray * int -> int + val unsafe_bytearray_update : ByteArray.bytearray * int * int -> unit + + val unsafe_floatarray_sub : FloatArray.floatarray * int -> real + val unsafe_floatarray_update : FloatArray.floatarray * int * real -> unit + + val unsafe_record_sub : 'a * int -> 'b + (* This is the really nasty one, only use to update a newer object with an older *) + val unsafe_record_update : 'a * int * 'b -> unit + + (* Unchecked ordof *) + val unsafe_string_sub : string * int -> int + + (* Allows destructive update of strings -- use with care *) + val unsafe_string_update : string * int * int -> unit + + (* Allocate an object of the specified type. *) + (* alloc_pair and alloc_vector initialize slots to 0 *) + (* alloc_string returns uninitialized string of given size *) + (* nb. size (alloc_string n) = n-1 as the terminating 0 is counted *) + + val alloc_pair : unit -> ml_value + val alloc_vector : int -> ml_value + val alloc_string : int -> string + + datatype print_options = + DEFAULT | + OPTIONS of {depth_max : int, + string_length_max : int, + indent : bool, + tags : bool} + val print : print_options * ml_value -> unit + + val pointer : T * int -> T + val primary : T -> int + val header : T -> int * int + val update_header : T * int * int -> unit + val sub : T * int -> T + val update : T * int * T -> unit + val sub_byte : T * int -> int + val update_byte : T * int * int -> unit + + val exn_name : exn -> string + val exn_argument : exn -> T + + val code_name : T -> string + + (* exceptions *) + val update_exn : exn * exn ref -> unit + val update_exn_cons : ('a -> exn) * ('a -> exn) ref -> unit + (* Note well *) + (* Since these functions update a pair, which is something *) + (* the gc is not expecting to happen, you should take care *) + (* that the value being placed into the pair is older *) + (* than the pair itself. Also, you should not use the updated *) + (* exception within a handler inside the structure in which *) + (* it (the exception which has been updated) was originally *) + (* defined. This is because the compiler will already have *) + (* the original unique available to it, and will use that *) + (* when generating the handle, rather then that update value *) + (* I would also advise against creating a handler in the same *) + (* structure as the one containing the called to update_exn, *) + (* for similar reasons *) + + (* This stuff should be implementable in a platform independent way *) + (* The meaning of frame offsets could be platform dependent though *) + structure Frame : + sig + eqtype frame + val sub : frame * int -> T + val update : frame * int * T -> unit + + (* Gives the frame of the calling function *) + val current : unit -> frame + val is_ml_frame : frame -> bool + + (* This stuff is required by the debugger but really ought to be *) + (* chucked out. *) + + val frame_call : (frame -> 'a) -> 'a + val frame_next : frame -> bool * frame * int + val frame_offset : frame * int -> T + val frame_double : frame * int -> T + val frame_allocations : frame -> bool + end + end + + structure Trace : + sig + exception Trace of string + val intercept : ('a -> 'b) * (Value.Frame.frame -> unit) -> unit + val replace : ('a -> 'b) * (Value.Frame.frame -> unit) -> unit + val restore : ('a -> 'b) -> unit + val restore_all : unit -> unit + datatype status = INTERCEPT | NONE | REPLACE | UNTRACEABLE + val status : ('a -> 'b) -> status + end + + structure Runtime : + sig + exception Unbound of string + val environment : string -> 'a + + val modules : (string * Value.T * Value.T) list ref + + structure Loader : + sig + exception Load of string + val load_module : string -> (string * Value.T) + val load_wordset : + int * + {a_names:string list, + b:{a_clos:int, b_spills:int, c_saves:int, d_code:string} list, + c_leafs:bool list, d_intercept:int list, + e_stack_parameters: int list} -> + (int * Value.T) list + end; + + structure Memory : + sig + val gc_message_level : int ref + val max_stack_blocks : int ref + val collect : int -> unit + val collect_all : unit -> unit + val collections : unit -> int * int + val promote_all : unit -> unit + end; + + structure Event : + sig + datatype T = SIGNAL of int + exception Signal of string + val signal : int * (int -> unit) -> unit + val stack_overflow_handler : (unit -> unit) -> unit + val interrupt_handler : (unit -> unit) -> unit + end; + end + + structure Dynamic : + sig + (* Dynamics are rather special. They can only be used in the + interpreter, and require special compiler support. The + generalises_ref is set in _scheme and used in the coerce + function. The coerce function is called by code that is + constructed by code in _typerep_utils. *) + + type dynamic + type type_rep + + exception Coerce of type_rep * type_rep + + val generalises_ref : ((type_rep * type_rep) -> bool) ref + + (* return a coerced value or raise Coerce Coerce (t,t') if + generalisation fails *) + val coerce : (dynamic * type_rep) -> Value.ml_value + end + + structure Exit : + sig + eqtype key + type status = Types.word32 + val success : status + val failure : status + val uncaughtIOException : status + val badUsage : status + val stop : status + val save : status + val badInput : status + val atExit : (unit -> unit) -> key + val removeAtExit : key -> unit + val exit : status -> 'a + val terminate : status -> 'a + end + + structure Debugger : + sig + val break_hook : (string -> unit) ref + val break : string -> unit + end + + end (* of structure Internal *) + structure Profile : + sig + type manner + type function_id = string + type cost_centre_profile = unit + + datatype object_kind = + RECORD + | PAIR + | CLOSURE + | STRING + | ARRAY + | BYTEARRAY + | OTHER (* includes weak arrays, code objects *) + | TOTAL (* only used when specifying a profiling manner *) + + datatype large_size = + Large_Size of + {megabytes : int, + bytes : int} + + datatype object_count = + Object_Count of + {number : int, + size : large_size, + overhead : int} + + datatype function_space_profile = + Function_Space_Profile of + {allocated : large_size, + copied : large_size, + copies : large_size list, + allocation : (object_kind * object_count) list list} + + datatype function_caller = + Function_Caller of + {id: function_id, + found: int, + top: int, + scans: int, + callers: function_caller list} + + datatype function_time_profile = + Function_Time_Profile of + {found: int, + top: int, + scans: int, + depth: int, + self: int, + callers: function_caller list} + + datatype function_profile = + Function_Profile of + {id: function_id, + call_count: int, + time: function_time_profile, + space: function_space_profile} + + datatype general_header = + General of + {data_allocated: int, + period: Internal.Types.time, + suspended: Internal.Types.time} + + datatype call_header = + Call of {functions : int} + + datatype time_header = + Time of + {data_allocated: int, + functions: int, + scans: int, + gc_ticks: int, + profile_ticks: int, + frames: real, + ml_frames: real, + max_ml_stack_depth: int} + + datatype space_header = + Space of + {data_allocated: int, + functions: int, + collections: int, + total_profiled : function_space_profile} + + type cost_header = unit + + datatype profile = + Profile of + {general: general_header, + call: call_header, + time: time_header, + space: space_header, + cost: cost_header, + functions: function_profile list, + centres: cost_centre_profile list} + + datatype options = + Options of + {scan : int, + selector : function_id -> manner} + + datatype 'a result = + Result of 'a + | Exception of exn + + exception ProfileError of string + + val profile : options -> ('a -> 'b) -> 'a -> ('b result * profile) + + val make_manner : + {time : bool, + space : bool, + calls : bool, + copies : bool, + depth : int, + breakdown : object_kind list} -> manner + end + + end (* of structure MLWorks *) ; diff --git a/src/pervasive/string.sml b/src/pervasive/string.sml new file mode 100644 index 00000000..26e9135c --- /dev/null +++ b/src/pervasive/string.sml @@ -0,0 +1,49 @@ +(* + * The strings library. + * + * Copyright (c) 1992 Harlequin Ltd. + * + * $Log: string.sml,v $ + * Revision 1.5 1996/05/21 12:02:43 matthew + * Adding maxLen + * + * Revision 1.4 1996/04/30 12:14:13 jont + * String functions explode, implode, chr and ord now only available from String + * io functions and types + * instream, oustream, open_in, open_out, close_in, close_out, input, output and end_of_stream + * now only available from MLWorks.IO + * + * Revision 1.3 1995/03/20 10:45:18 matthew + * Adding implode_char function + * + * Revision 1.2 1994/02/08 10:55:06 nickh + * Added ml_string(). + * + * Revision 1.1 1992/08/07 10:42:29 davidt + * Initial revision + * + * + *) + +signature STRING = + sig + exception Substring + exception Chr + exception Ord + val maxLen : int + val explode : string -> string list + val implode : string list -> string + val chr : int -> string + val ord : string -> int + val substring : string * int * int -> string + val < : string * string -> bool + val > : string * string -> bool + val <= : string * string -> bool + val >= : string * string -> bool + val ordof : string * int -> int + + val ml_string : string * int -> string + + val implode_char : int list -> string + + end; diff --git a/src/pervasive/vector.sml b/src/pervasive/vector.sml new file mode 100644 index 00000000..eb54cdad --- /dev/null +++ b/src/pervasive/vector.sml @@ -0,0 +1,27 @@ +(* + * The vector module. + * + * Copyright (c) 1992 Harlequin Ltd. + * + * $Log: vector.sml,v $ + * Revision 1.2 1996/05/21 11:48:58 matthew + * Adding maxLen + * Adding maxLen + * + * Revision 1.1 1992/12/21 11:18:59 daveb + * Initial revision + * + * + *) + +signature VECTOR = + sig + eqtype 'a vector + exception Size + exception Subscript + val vector: 'a list -> 'a vector + val tabulate: int * (int -> 'a) -> 'a vector + val sub: 'a vector * int -> 'a + val length: 'a vector -> int + val maxLen : int + end diff --git a/src/rts/.gitignore b/src/rts/.gitignore index e71c85d5..e085ffaf 100644 --- a/src/rts/.gitignore +++ b/src/rts/.gitignore @@ -10,3 +10,5 @@ obj/ *.pdb *.dll *.obj +runtime +runtime-g diff --git a/src/rts/GNUmakefile b/src/rts/GNUmakefile index b949d0f5..4e030fe8 100755 --- a/src/rts/GNUmakefile +++ b/src/rts/GNUmakefile @@ -262,7 +262,7 @@ # # and do "gnumake" -CMODULES = alloc allocator arena bytearrays cache diagnostic endian \ +CMODULES = alloc allocator arena bytearrays cache diagnostic mlw_endian \ environment event exceptions fixup \ gc global image implicit initialise integers intercept \ license lists loader marshal mem modules \ @@ -398,8 +398,12 @@ DEPENDDIR = depend/$(ARCH)/$(OS) ifeq "$(NTTYPE)" "TRUE" RUNTIMES = runtime runtime-g runtime-windows runtime-windows-g else +ifeq "$(OS)" "Linux" +RUNTIMES = runtime runtime-g +else RUNTIMES = runtime runtime-g runtime-static endif +endif all: $(GENERATED) $(RUNTIMES) generated: $(GENERATED) @@ -569,8 +573,8 @@ vpath %.S \ # automatically kept up to date by the general rules above. # For details, see the GNU make documentation. -include $(MODULESSTATIC:%=$(DEPENDDIR)/%.d) -include $(DEPENDDIR)/test_fixup.d +-include $(MODULESSTATIC:%=$(DEPENDDIR)/%.d) +-include $(DEPENDDIR)/test_fixup.d # === TARGETS === @@ -649,12 +653,15 @@ endif ifeq "$(NTTYPE)" "TRUE" else +ifeq "$(OS)" "Linux" # Can't find libXaw.a on Ubuntu 12 +else $(TARGETDIR)/main-static: $(OBJECTSSTATIC) @echo 'MAKE: $@' @$(MKDIR) $(TARGETDIR) $(MKDIREND) @$(LINK) -Xlinker -Bstatic $(LINKFLAGS)$@ $(OBJECTSSTATIC) $(LIBRARIESSTATIC) $(LINKENDFLAGS) @$(STRIP) $@ endif +endif @@ -758,10 +765,13 @@ endif ifeq "$(NTTYPE)" "TRUE" else +ifeq "$(OS)" "Linux" # Can't find libXaw.a on Ubuntu 12 +else runtime-static: force $(TARGETDIR)/main-static @$(RM) $@ $(LN) -s $(TARGETDIR)/main-static $@ endif +endif ifeq "$(OS)" "SunOS" runtime-g: old-runtime-g diff --git a/src/rts/awk/__objectfile.awk b/src/rts/awk/__objectfile.awk index 080e5a97..c5e672ea 100755 --- a/src/rts/awk/__objectfile.awk +++ b/src/rts/awk/__objectfile.awk @@ -4,6 +4,14 @@ BEGIN { print " * Object file opcodes"; print " * Machine generated file : DO NOT ALTER"; print " * Generated from : objectfile.h"; + print " *"; + print " * The generated copy of this file in src/rts/gen is information"; + print " * about the object files that the *current runtime* can load"; + print " * and *not* necessarily what the compiler generates. This file"; + print " * should be hand-copied to src/main/__objectfile.sml for use"; + print " * by the compiler, with version numbers for the object files"; + print " * that the source code of the compiler actually outputs."; + print " *"; print " * Copyright 2013 Ravenbrook Limited"; print " *)"; print ("\nstructure ObjectFile_ ="); diff --git a/src/rts/src/OS/Linux/arch/I386/GNUmake b/src/rts/src/OS/Linux/arch/I386/GNUmake index 2695b79d..0923e758 100755 --- a/src/rts/src/OS/Linux/arch/I386/GNUmake +++ b/src/rts/src/OS/Linux/arch/I386/GNUmake @@ -80,20 +80,20 @@ DEFINES := $(DEFINES) MACH_FIXUP LITTLE_ENDIAN _SVID_SOURCE SPACE_PROFILE_OVERF # add target-specific includes -INCLUDEDIRS := $(INCLUDEDIRS) - /usr/X11R6/include /usr/X11/include +INCLUDEDIRS := $(INCLUDEDIRS) # add target-specific options (none for SunOS) -TARGETOPTS = -TARGETOPTSDEBUG = +TARGETOPTS = -m32 +TARGETOPTSDEBUG = $(TARGETOPTS) DLLLIBRARIES = DLLFLAGS = -shared # add target-specific libraries -LIBRARIES = -L/usr/lib -L/usr/X11R6/lib -L/usr/X11/lib -L/lib -L/usr/X11R6/lib/xrt/lib -lm -lXm -lXt -lXext -lX11 -lXpm -lXp -lelf -ldl -LIBRARIESSTATIC = -L/usr/lib -L/usr/X11R6/lib -L/usr/X11/lib -L/usr/X11R6/lib/xrt/lib -Xlinker -Bstatic -lXm -Xlinker -Bdynamic -lm -lSM -lICE -lXt -lX11 -lXp -lelf -ldl -lXpm -lXext +LIBRARIES = -lm -lXm -lXt -lXext -lX11 -lXpm -lelf -ldl +LIBRARIESSTATIC = -Xlinker -Bstatic -lXm -Xlinker -Bdynamic -lm -lSM -lICE -lXt -lX11 -lelf -ldl -lXpm -lXext -lXft # other target-specific things diff --git a/src/rts/src/OS/Linux/arch/I386/exec_delivery.c b/src/rts/src/OS/Linux/arch/I386/exec_delivery.c index 776cfd5f..9102a758 100755 --- a/src/rts/src/OS/Linux/arch/I386/exec_delivery.c +++ b/src/rts/src/OS/Linux/arch/I386/exec_delivery.c @@ -71,11 +71,12 @@ */ #include -#include +#include #include #include #include #include +#include #include "exec_delivery.h" #include "gc.h" diff --git a/src/rts/src/OS/Linux/arena.c b/src/rts/src/OS/Linux/arena.c index 2bef27cb..c5ca38c3 100755 --- a/src/rts/src/OS/Linux/arena.c +++ b/src/rts/src/OS/Linux/arena.c @@ -177,8 +177,6 @@ size_t arena_extent = 0; size_t max_arena_extent = 0; #endif -static int zero_device; -static int reserve_device; static int page_size; /* arena_state is UNINITIALIZED until the arena has been initialized. @@ -237,8 +235,8 @@ static void map(void *start, size_t length) while(length > 0 && mmap((caddr_t)start, length, PROT_READ | PROT_WRITE | PROT_EXEC, - MAP_FIXED | MAP_PRIVATE, - zero_device, 0) == (caddr_t)-1) + MAP_FIXED | MAP_PRIVATE | MAP_ANON, + -1, 0) == (caddr_t)-1) switch(errno) { /* The Linux kernel sources tell me that this can fail with either * ENOMEM or EAGAIN */ @@ -264,13 +262,12 @@ static void map(void *start, size_t length) static void unmap(void *start, size_t length) { - /* We simply rereserve this via mmap on reserve_device, - * rather than unmapping */ + /* We simply rereserve this via mmap but with no backing store, rather than unmapping */ int space = SPACE(start); off_t offset = (unsigned long)start - (unsigned long)(SPACE_BASE(space)); if (length > 0 && - mmap((caddr_t)start, length, PROT_NONE, MAP_FIXED | MAP_SHARED, - reserve_device, offset) == (caddr_t)-1) { + mmap((caddr_t)start, length, PROT_NONE, MAP_FIXED | MAP_PRIVATE | MAP_ANON, + -1, offset) == (caddr_t)-1) { error("unmap has failed with an unexpected error code %d meaning %s\n", errno, strerror(errno)); }; @@ -322,7 +319,7 @@ void test_mapping(void) #endif /* It seems that mmap()s past 0x60000000 will break Linux. */ - +/* FIXME: no longer needed */ #define ARENA_LIMIT 0x60000000 /* @@ -335,12 +332,23 @@ void test_mapping(void) static int reserve_arena_space(caddr_t *base) { int space; - *base = mmap((caddr_t)0, SPACE_SIZE, PROT_NONE, MAP_SHARED, - reserve_device, (off_t)0); - if (*base == (caddr_t)-1 || (unsigned long)(*base) > ARENA_LIMIT) { + void* addr = *base; + *base = mmap(addr, SPACE_SIZE, PROT_NONE, MAP_PRIVATE | MAP_ANON, + -1, (off_t)0); + if (*base == (caddr_t)-1) { /* Failed to reserve */ return 1; } + + /* FIXME: no longer needed + if ((unsigned long)(*base) > ARENA_LIMIT) { + DIAGNOSTIC(1, " mmaped address %p is above ARENA_LIMIT %p; retrying", + *base, ARENA_LIMIT); + *base = addr; + return reserve_arena_space (base); + } + */ + space = SPACE(((word)(*base)) + (SPACE_SIZE) -1); if ((caddr_t)(SPACE_BASE(space)) != *base) { /* Oh dear, we've got an unaligned piece of space */ @@ -348,8 +356,8 @@ static int reserve_arena_space(caddr_t *base) if (munmap(*base, SPACE_SIZE) == -1) { error("munmap(1)(0x%x, 0x%x) has returned an unexpected error code %d meaning %s", *base, SPACE_SIZE, errno, strerror(errno)); } - *base = mmap((caddr_t)0, 2*(SPACE_SIZE), PROT_NONE, MAP_SHARED, - reserve_device, (off_t)0); + *base = mmap((caddr_t)0, 2*(SPACE_SIZE), PROT_NONE, MAP_PRIVATE | MAP_ANON, + -1, (off_t)0); if (*base == (caddr_t)-1) { /* Failed to reserve */ return 1; @@ -425,13 +433,6 @@ void arena_init(void) arena_state = INITIALIZING; page_size = getpagesize(); - zero_device = open("/dev/zero", O_RDONLY); - if(zero_device == -1) - error_without_alloc("Arena initializing unable to open /dev/zero."); - reserve_device = open("/etc/passwd", O_RDONLY); - if(reserve_device == -1) - error_without_alloc("Arena initializing unable to open /etc/passwd."); - /* First mark all spaces reserved */ for (i = 0; i < NR_SPACES; i++) { space_type[i] = TYPE_RESERVED; @@ -442,7 +443,7 @@ void arena_init(void) /* Now allocate the spaces we want */ for (i = 0; i < 2; i++) { int space; - caddr_t base; + caddr_t base = (caddr_t)((i + 1) * SPACE_SIZE); /* Hack RB 2013-05-18 because mmap was returning addresses above ARENA_LIMIT */ if (reserve_arena_space(&base)) { error_without_alloc("Arena initializing unable to reserve memory\n"); } diff --git a/src/rts/src/OS/Linux/foreign_loader.c b/src/rts/src/OS/Linux/foreign_loader.c index 7710864b..369664bb 100755 --- a/src/rts/src/OS/Linux/foreign_loader.c +++ b/src/rts/src/OS/Linux/foreign_loader.c @@ -82,7 +82,7 @@ #include "foreign_loader.h" #include /* Run-Time Dynamic Linking libraries */ -#include /* ELF libraries -- Linux */ +#include /* ELF libraries -- Linux */ #include #include diff --git a/src/rts/src/OS/Linux/localreals.c b/src/rts/src/OS/Linux/localreals.c index eb43901d..035329bf 100644 --- a/src/rts/src/OS/Linux/localreals.c +++ b/src/rts/src/OS/Linux/localreals.c @@ -49,10 +49,12 @@ static double posinf = 1.0/0.0; /* It appears that abs doesn't work properly under Linux either */ +#if 0 /* RB 2013-05-18 */ static double abs(double a) { return ((a >= 0.0) ? a : -a); } +#endif extern int localpower(double a, double b, double *result) { diff --git a/src/rts/src/OS/Linux/os.c b/src/rts/src/OS/Linux/os.c index f3cb9f98..7023f18b 100755 --- a/src/rts/src/OS/Linux/os.c +++ b/src/rts/src/OS/Linux/os.c @@ -89,12 +89,16 @@ #include "syscalls.h" #include "diagnostic.h" #include "utils.h" +#include + extern void os_init(void) { + unsigned short cw; unix_init(); /* This should be done properly sometime */ - __setfpucw (0x037f); + cw = 0x037f; + _FPU_SETCW(cw); x_init(); } @@ -161,7 +165,7 @@ extern void os_set_rounding_mode (int arg) control = modes[arg]; old = get_fpu_control_word(); control |= (old & (~_FPU_MASK)); - __setfpucw(control); + _FPU_SETCW(control); } /* The behaviour of malloc(0), realloc(NULL,0) and realloc(p,0) diff --git a/src/rts/src/OS/Linux/syscalls.h b/src/rts/src/OS/Linux/syscalls.h index c7bfdad1..e5ceec01 100755 --- a/src/rts/src/OS/Linux/syscalls.h +++ b/src/rts/src/OS/Linux/syscalls.h @@ -118,6 +118,7 @@ extern long int gethostid __P ((void)); /* struct timespec, messed up in Red Hat 5 */ +#if 0 /* RB 2013-05-18 */ #ifndef _STRUCT_TIMESPEC #define _STRUCT_TIMESPEC struct timespec { @@ -125,6 +126,7 @@ struct timespec { long tv_nsec; /* nanoseconds */ }; #endif /* _STRUCT_TIMESPEC */ +#endif /* lstat, messed up in Red Hat 5 */ @@ -132,6 +134,9 @@ struct timespec { /* S_ISLNK and S_ISSOCK, also screwed up in Red Hat 5 */ +#if 0 /* RB 2013-05-18 */ #define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +#endif #define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) + #endif /* syscall_h */ diff --git a/src/rts/src/OS/Unix/GNUmake b/src/rts/src/OS/Unix/GNUmake index 1ecd06b7..57a2e5d0 100755 --- a/src/rts/src/OS/Unix/GNUmake +++ b/src/rts/src/OS/Unix/GNUmake @@ -69,8 +69,8 @@ GCC = gcc # Use GCC for: compiling, assembling, linking, and generating dependencies. COMPILE = $(GCC) -COMPILEFLAGS = $(GCCFLAGS) -c -o -COMPILEFLAGSDEBUG = $(GCCFLAGSDEBUG) -c -o +COMPILEFLAGS = $(GCCFLAGS) -falign-functions=4 -c -o +COMPILEFLAGSDEBUG = $(GCCFLAGSDEBUG) -falign-functions=4 -c -o ASM = $(GCC) ASMFLAGS = $(GCCFLAGS) -c -o diff --git a/src/rts/src/OS/Unix/export.c b/src/rts/src/OS/Unix/export.c index 09a09809..9ed33595 100755 --- a/src/rts/src/OS/Unix/export.c +++ b/src/rts/src/OS/Unix/export.c @@ -92,6 +92,7 @@ #include /* WIFERXITED, ... */ #include #include /* assert */ +#include #include "diagnostic.h" #include "gc.h" diff --git a/src/rts/src/OS/Unix/time_date.c b/src/rts/src/OS/Unix/time_date.c index 86cd403c..a8ea330e 100755 --- a/src/rts/src/OS/Unix/time_date.c +++ b/src/rts/src/OS/Unix/time_date.c @@ -112,6 +112,7 @@ #include #include /* struct timeval, mktime, ... */ #include /* LONG_MAX ... */ +#include #include "alloc.h" /* free */ #include "allocator.h" /* allocate_real, allocate_record */ #include "date.h" /* mlw_date_hour ... */ diff --git a/src/rts/src/OS/Unix/unix.c b/src/rts/src/OS/Unix/unix.c index 2b80367c..974b775c 100755 --- a/src/rts/src/OS/Unix/unix.c +++ b/src/rts/src/OS/Unix/unix.c @@ -234,11 +234,13 @@ #include /* mode_t ... */ #include #include /* mkdir, chmod, umask, S_ISDIR, ... */ +#include /* S_ISSOCK */ #include /* opendir, ... etc. */ #include /* open, creat, O_RDONLY, ... */ #include /* FIONREAD */ #include /* struct passwd */ #include /* utime, utimbuf */ +#include /* lstat */ #include "syscalls.h" #ifndef MLW_OVERRIDE_RUSAGE @@ -483,7 +485,7 @@ static mlval unix_connect(mlval arg) static mlval unix_getsockname(mlval arg) { char buffer[SOCKADDR_BUFFER]; - int namelen = SOCKADDR_BUFFER; + socklen_t namelen = SOCKADDR_BUFFER; struct sockaddr *sa = (struct sockaddr *)buffer; struct sockaddr_un *un = (struct sockaddr_un *)buffer; mlval result; @@ -506,7 +508,7 @@ static mlval unix_getsockname(mlval arg) static mlval unix_getpeername(mlval arg) { char buffer[SOCKADDR_BUFFER]; - int namelen = SOCKADDR_BUFFER; + socklen_t namelen = SOCKADDR_BUFFER; struct sockaddr *sa = (struct sockaddr *)buffer; struct sockaddr_un *un = (struct sockaddr_un *)buffer; mlval result; @@ -529,7 +531,7 @@ static mlval unix_getpeername(mlval arg) static mlval unix_accept(mlval arg) { char buffer[SOCKADDR_BUFFER]; - int namelen = SOCKADDR_BUFFER, s; + socklen_t namelen = SOCKADDR_BUFFER, s; struct sockaddr *sa = (struct sockaddr *)buffer; struct sockaddr_un *un = (struct sockaddr_un *)buffer; mlval ml_sockaddr, result; diff --git a/src/rts/src/OS/Unix/x.c b/src/rts/src/OS/Unix/x.c index dea3584b..8a3eca70 100755 --- a/src/rts/src/OS/Unix/x.c +++ b/src/rts/src/OS/Unix/x.c @@ -4256,7 +4256,7 @@ static void message_dlg_callback void display_simple_message_box(const char *message) { if (applicationShell == NULL) { - fprintf(stderr, message); + fputs(message, stderr); } else { static Widget dialog; XmString text; diff --git a/src/rts/src/arch/I386/mach_state.h b/src/rts/src/arch/I386/mach_state.h index 4e4932d2..016e776f 100755 --- a/src/rts/src/arch/I386/mach_state.h +++ b/src/rts/src/arch/I386/mach_state.h @@ -90,7 +90,7 @@ void initialize_c_state(struct c_state *c_state); void initialize_top_thread_state(void); -#define GC_RETURN ((mlval *)CURRENT_THREAD->ml_state.global) +#define GC_RETURN (*(mlval **)&CURRENT_THREAD->ml_state.global) #define GC_SP(thread) ((struct stack_frame *)(thread)->ml_state.sp) #define C_PC(c_state) ((c_state)->eip) diff --git a/src/rts/src/arena.h b/src/rts/src/arena.h index 7bdd6761..d55ab531 100755 --- a/src/rts/src/arena.h +++ b/src/rts/src/arena.h @@ -142,7 +142,7 @@ extern size_t space_extent[NR_SPACES]; For other spaces, it is at the disposal of the client. */ extern void *space_info[NR_SPACES]; -#define SPACE_MAP(space) ((byte*) space_info[space]) +#define SPACE_MAP(space) (*(byte **)&space_info[space]) #define TYPE(addr) \ (space_type[SPACE(addr)] != TYPE_BLOCKS ? \ diff --git a/src/rts/src/dtoa.c b/src/rts/src/dtoa.c index f3b3128e..bacb500c 100755 --- a/src/rts/src/dtoa.c +++ b/src/rts/src/dtoa.c @@ -1902,10 +1902,11 @@ strtod if ((word0(rv) & Exp_mask) <= P*Exp_msk1 && word1(rv) & 1 && dsign != 2) - if (dsign) + if (dsign) { rv += ulp(rv); - else + } else { word1(rv) &= ~1; + } word0(rv0) = Exp_1 - P*Exp_msk1; word1(rv0) = 0; rv *= rv0; diff --git a/src/rts/src/environment.c b/src/rts/src/environment.c index 8d070705..5ce4ed2a 100755 --- a/src/rts/src/environment.c +++ b/src/rts/src/environment.c @@ -268,7 +268,7 @@ static mlval new_stub (const char *string, mlval (*f)(mlval), mlval type, mlval code) { mlval closure, name, dummy_code; - + assert(is_word_aligned(f)); #ifdef OS_NT assert(CINT(MLINT(f)) == (int)f); f = (mlval (*)(mlval))(MLINT(f)); /* NT compilers don't align functions properly */ diff --git a/src/rts/src/gc.c b/src/rts/src/gc.c index 12e76c23..f4ad0a81 100755 --- a/src/rts/src/gc.c +++ b/src/rts/src/gc.c @@ -2142,7 +2142,7 @@ void gc(size_t space_required, mlval closure) } else heap_analysis_count(creation->start,creation->top); } -#endif DEBUG +#endif /* DEBUG */ gc_statistics(gc_stat_stream, user_clock(), 0); diff --git a/src/rts/src/integers.c b/src/rts/src/integers.c index 78c7a021..766f1f27 100755 --- a/src/rts/src/integers.c +++ b/src/rts/src/integers.c @@ -157,8 +157,8 @@ static mlval modulo (mlval argument) static mlval int32_mul(mlval argument) { - int *val1 = CWORD32(FIELD(argument,0)), - *val2 = CWORD32(FIELD(argument,1)); + int *val1 = CINT32(FIELD(argument,0)), + *val2 = CINT32(FIELD(argument,1)); mlval result; double prod = ((double) *val1) * ((double) *val2); if ((prod > (double) ML_MAX_INT32)) @@ -192,8 +192,8 @@ static mlval int32_div(mlval argument) { int answer, remainder, - *divisor = CWORD32(FIELD(argument,0)), - *dividend = CWORD32(FIELD(argument,1)); + *divisor = CINT32(FIELD(argument,0)), + *dividend = CINT32(FIELD(argument,1)); mlval result; if (*dividend == 0u) exn_raise(perv_exn_ref_div); @@ -215,8 +215,8 @@ static mlval int32_div(mlval argument) static mlval int32_mod(mlval argument) { int answer, - *divisor = CWORD32(FIELD(argument,0)), - *dividend = CWORD32(FIELD(argument,1)); + *divisor = CINT32(FIELD(argument,0)), + *dividend = CINT32(FIELD(argument,1)); mlval result; if (*dividend == 0u) exn_raise(perv_exn_ref_div); diff --git a/src/rts/src/loader.c b/src/rts/src/loader.c index db410013..e363c6f7 100755 --- a/src/rts/src/loader.c +++ b/src/rts/src/loader.c @@ -413,7 +413,7 @@ #include "objectfile.h" #include "allocator.h" #include "interface.h" -#include "endian.h" +#include "mlw_endian.h" #include "modules.h" #include "diagnostic.h" #include "utils.h" diff --git a/src/rts/src/marshal.c b/src/rts/src/marshal.c index c512bee4..a948549e 100755 --- a/src/rts/src/marshal.c +++ b/src/rts/src/marshal.c @@ -100,14 +100,14 @@ char *marshal(char *out, const char *desc, ...) /* Characters are encoded as themselves. */ case 'c': - *out++ = va_arg(arg, char); + *out++ = va_arg(arg, int); /* promoted from char */ break; /* Integers are encoded in 7-bit chunks with the eighth bit indicating */ /* that there is another chunk to come. */ case 's': - out = marshal_long(out, (unsigned long int)va_arg(arg, unsigned short int)); + out = marshal_long(out, (unsigned long int)va_arg(arg, int)); /* promoted from unsigned short int */ break; case 'i': diff --git a/src/rts/src/mem.c b/src/rts/src/mem.c index 44b6f472..2de8d2b3 100755 --- a/src/rts/src/mem.c +++ b/src/rts/src/mem.c @@ -281,7 +281,7 @@ struct ml_heap *space_gen[SPACES_IN_ARENA]; static struct ml_stack *stack_cache = NULL; static size_t stack_cache_size = 0, stack_total = 0; -static stack_blocks = 0; +static int stack_blocks = 0; /* == Making and unmaking stacks == */ diff --git a/src/rts/src/mem.h b/src/rts/src/mem.h index 77467312..48d8344c 100755 --- a/src/rts/src/mem.h +++ b/src/rts/src/mem.h @@ -297,7 +297,7 @@ struct ml_static_space /* SPACE_STATIC(space) gives the static space descriptor for the space */ -#define SPACE_STATIC(space) ((struct ml_static_space *)space_info[space]) +#define SPACE_STATIC(space) (*(struct ml_static_space **)&space_info[space]) /* == Generation descriptor == * diff --git a/src/rts/src/endian.c b/src/rts/src/mlw_endian.c similarity index 98% rename from src/rts/src/endian.c rename to src/rts/src/mlw_endian.c index 8006ddd7..362bdb20 100755 --- a/src/rts/src/endian.c +++ b/src/rts/src/mlw_endian.c @@ -1,5 +1,5 @@ /* - * endian.c + * mlw_endian.c * Handle endian change requirements. * $Log: endian.c,v $ * Revision 1.4 1996/02/14 10:09:49 jont @@ -63,7 +63,7 @@ */ #include "types.h" -#include "endian.h" +#include "mlw_endian.h" #include "objectfile.h" /* diff --git a/src/rts/src/endian.h b/src/rts/src/mlw_endian.h similarity index 97% rename from src/rts/src/endian.h rename to src/rts/src/mlw_endian.h index 046b2899..b23368fd 100755 --- a/src/rts/src/endian.h +++ b/src/rts/src/mlw_endian.h @@ -1,5 +1,5 @@ /* - * endian.h + * mlw_endian.h * Handle endian change requirements. * $Log: endian.h,v $ * Revision 1.2 1994/06/09 14:34:28 nickh @@ -50,8 +50,8 @@ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -#ifndef endian_h -#define endian_h +#ifndef mlw_endian_h +#define mlw_endian_h #include "types.h" diff --git a/src/rts/src/sockets.c b/src/rts/src/sockets.c index 8b84f0e0..3d309e3e 100755 --- a/src/rts/src/sockets.c +++ b/src/rts/src/sockets.c @@ -623,7 +623,7 @@ static mlval sock_controlflg (mlval arg, int option) int flg, sts; if (mlw_option_is_none(ctl)) { - int optSz = sizeof(int); + socklen_t optSz = sizeof(int); sts = getsockopt (sock, SOL_SOCKET, option, (char *)&flg, &optSz); assert((sts == SOCKET_ERROR) || (optSz == sizeof(int))); if (sts == SOCKET_ERROR) @@ -681,7 +681,7 @@ static mlval ml_ctllinger(mlval arg) int sts; if (mlw_option_is_none(ctl)) { - int optSz = sizeof(struct linger); + socklen_t optSz = sizeof(struct linger); sts = getsockopt (sock, SOL_SOCKET, SO_LINGER, (char *)&optVal, &optSz); assert((sts == SOCKET_ERROR) || (optSz == sizeof(struct linger))); } else { @@ -727,7 +727,7 @@ static mlval ml_ctlsndbuf(mlval arg) int sz, sts; if (mlw_option_is_none(ctl)) { - int optSz = sizeof(int); + socklen_t optSz = sizeof(int); sts = getsockopt (sock, SOL_SOCKET, SO_SNDBUF, (char *)&sz, &optSz); assert((sts == SOCKET_ERROR) || (optSz == sizeof(int))); } else { @@ -804,7 +804,7 @@ static mlval ml_ctlnodelay(mlval arg) int sts; if (mlw_option_is_none(ctl)) { - int optSz = sizeof(int); + socklen_t optSz = sizeof(int); sts = getsockopt (sock, IPPROTO_TCP, TCP_NODELAY, (char *)&flg, &optSz); assert((sts == SOCKET_ERROR) || (optSz == sizeof(int))); } else { @@ -822,7 +822,8 @@ static mlval ml_geterror(mlval arg) /* : sockFD -> bool */ { SOCKET sock = CINT(arg); - int flg, sts, optSz = sizeof(int); + int flg, sts; + socklen_t optSz = sizeof(int); sts = getsockopt (sock, SOL_SOCKET, SO_ERROR, (char *)&flg, &optSz); @@ -839,7 +840,8 @@ static mlval ml_gettype(mlval arg) /* : sockFD -> CI.system_const */ { SOCKET sock = CINT(arg); - int flg, sts, optSz = sizeof(int); + int flg, sts; + socklen_t optSz = sizeof(int); sts = getsockopt (sock, SOL_SOCKET, SO_TYPE, (char *)&flg, &optSz); @@ -854,7 +856,7 @@ static mlval ml_getpeername(mlval arg) { SOCKET sock = CINT(arg); char addrBuf[MAX_SOCK_ADDR_SZB]; - int addrLen = MAX_SOCK_ADDR_SZB; + socklen_t addrLen = MAX_SOCK_ADDR_SZB; int sts; sts = getpeername (sock, (struct sockaddr *)addrBuf, &addrLen); @@ -874,7 +876,7 @@ static mlval ml_getsockname(mlval arg) { SOCKET sock = CINT(arg); char addrBuf[MAX_SOCK_ADDR_SZB]; - int addrLen = MAX_SOCK_ADDR_SZB; + socklen_t addrLen = MAX_SOCK_ADDR_SZB; int sts; sts = getsockname (sock, (struct sockaddr *)addrBuf, &addrLen); @@ -905,7 +907,7 @@ static mlval ml_accept(mlval arg) { SOCKET sock = CINT(arg); char addrBuf[MAX_SOCK_ADDR_SZB]; - int addrLen = MAX_SOCK_ADDR_SZB; + socklen_t addrLen = MAX_SOCK_ADDR_SZB; SOCKET newSock; newSock = accept (sock, (struct sockaddr *)addrBuf, &addrLen); @@ -1017,7 +1019,7 @@ static mlval ml_sendbuf(mlval arg) if (SECONDARY(GETHEADER(buffer)) == STRING) data = CSTRING(buffer) + CINT(FIELD(arg, 2)); else - data = CBYTEARRAY(buffer) + CINT(FIELD(arg, 2)); + data = (char *)CBYTEARRAY(buffer) + CINT(FIELD(arg, 2)); /* initialize the flags */ flgs = 0; @@ -1050,7 +1052,7 @@ static mlval ml_sendbufto(mlval arg) if (SECONDARY(GETHEADER(buffer)) == STRING) data = CSTRING(buffer) + CINT(FIELD(arg, 2)); else - data = CBYTEARRAY(buffer) + CINT(FIELD(arg, 2)); + data = (char *)CBYTEARRAY(buffer) + CINT(FIELD(arg, 2)); /* initialize the flags. */ flgs = 0; @@ -1111,7 +1113,7 @@ static mlval ml_recvbuf(mlval arg) */ { SOCKET sock = CINT(FIELD(arg, 0)); - char *start = CBYTEARRAY(FIELD(arg, 1)) + CINT(FIELD(arg, 2)); + char *start = (char *)CBYTEARRAY(FIELD(arg, 1)) + CINT(FIELD(arg, 2)); int nbytes = CINT(FIELD(arg, 3)); int flag = 0; int n; @@ -1134,7 +1136,7 @@ static mlval ml_recvfrom(mlval arg) */ { char addrBuf[MAX_SOCK_ADDR_SZB]; - int addrLen = MAX_SOCK_ADDR_SZB; + socklen_t addrLen = MAX_SOCK_ADDR_SZB; SOCKET sock = CINT(FIELD(arg, 0)); int nbytes = CINT(FIELD(arg, 1)); int flag = 0; @@ -1187,9 +1189,9 @@ static mlval ml_recvbuffrom(mlval arg) */ { char addrBuf[MAX_SOCK_ADDR_SZB]; - int addrLen = MAX_SOCK_ADDR_SZB; + socklen_t addrLen = MAX_SOCK_ADDR_SZB; SOCKET sock = CINT(FIELD(arg, 0)); - char *start = CBYTEARRAY(FIELD(arg, 1)) + CINT(FIELD(arg, 2)); + char *start = (char *)CBYTEARRAY(FIELD(arg, 1)) + CINT(FIELD(arg, 2)); int nbytes = CINT(FIELD(arg, 3)); int flag = 0; int n; diff --git a/src/rts/src/state.h b/src/rts/src/state.h index c8a346ea..00e1ebfc 100755 --- a/src/rts/src/state.h +++ b/src/rts/src/state.h @@ -49,9 +49,9 @@ extern struct global_state global_state; #define TOP_THREAD global_state.toplevel #define GC_MODIFIED_LIST CURRENT_THREAD->implicit.gc_modified_list -#define GC_HEAP_START ((mlval *)CURRENT_THREAD->implicit.gc_base) -#define GC_HEAP_LIMIT ((mlval *)CURRENT_THREAD->implicit.gc_limit) -#define GC_HEAP_REAL_LIMIT ((mlval *)CURRENT_THREAD->implicit.real_gc_limit) +#define GC_HEAP_START (*(mlval **)&CURRENT_THREAD->implicit.gc_base) +#define GC_HEAP_LIMIT (*(mlval **)&CURRENT_THREAD->implicit.gc_limit) +#define GC_HEAP_REAL_LIMIT (*(mlval **)&CURRENT_THREAD->implicit.real_gc_limit) #define GC_STACK(thread) (thread)->implicit.stack_limit /* GC_SP(thread) and GC_RETURN are machine-specific, so are obtained diff --git a/src/rts/src/threads.c b/src/rts/src/threads.c index 7255d727..f19baa55 100755 --- a/src/rts/src/threads.c +++ b/src/rts/src/threads.c @@ -271,7 +271,7 @@ static void unmake_thread (struct thread_state *thread) thread->last->next = thread->next; /* disentangle from ML */ - C_THREAD(ML_THREAD(thread)) = (mlval) NULL; + C_THREAD(ML_THREAD(thread)) = NULL; ML_THREAD(thread) = MLUNIT; retract_root(&thread->ml_thread); retract_root(&thread->implicit.handler); @@ -468,7 +468,7 @@ static mlval thread_fix(unsigned int index, mlval ml_thread) break; default: message("expired thread %d", index); - C_THREAD(ml_thread) = (mlval) NULL; + C_THREAD(ml_thread) = NULL; SET_RESULT(ml_thread,THREAD_EXPIRED); } return ml_thread; diff --git a/src/rts/src/threads.h b/src/rts/src/threads.h index 18e432f9..01839d09 100755 --- a/src/rts/src/threads.h +++ b/src/rts/src/threads.h @@ -189,7 +189,7 @@ extern int thread_in_critical_section; extern int runnable_threads; #define ML_THREAD(c_thread) ((c_thread)->ml_thread) -#define C_THREAD(ml_thread) ((struct thread_state *)(FIELD(ml_thread,1))) +#define C_THREAD(ml_thread) (*(struct thread_state **)(&FIELD(ml_thread,1))) #define THREAD_DIED (MLINT(0)) /* received fatal signal */ #define THREAD_EXCEPTION (MLINT(1)) /* raised uncaught exn */ diff --git a/src/rts/src/values.h b/src/rts/src/values.h index 33a17170..b9f7e536 100755 --- a/src/rts/src/values.h +++ b/src/rts/src/values.h @@ -520,6 +520,7 @@ CCODE_NUMBER_BITS : how many bits in the 'number' field. */ #define CWORD32(v) ((word *)CSTRING(v)) +#define CINT32(v) ((int *)CSTRING(v)) /* == Booleans == diff --git a/src/typechecker/_assemblies.sml b/src/typechecker/_assemblies.sml index d22d60bb..6f19e4ad 100644 --- a/src/typechecker/_assemblies.sml +++ b/src/typechecker/_assemblies.sml @@ -389,8 +389,10 @@ functor Assemblies( lsub a_list end - val empty_str_offspring = NewMap.empty (Ident.strid_lt,Ident.strid_eq) - val empty_type_offspring = NewMap.empty (Ident.tycon_lt,Ident.tycon_eq) + val empty_str_offspring : StrOffspring + = NewMap.empty (Ident.strid_lt,Ident.strid_eq) + val empty_type_offspring : TypeOffspring + = NewMap.empty (Ident.tycon_lt,Ident.tycon_eq) val empty_strassembly = fn _ => [] val empty_tyassembly = IntMap.empty diff --git a/src/typechecker/_share.sml b/src/typechecker/_share.sml index 0a314649..b3b409b1 100644 --- a/src/typechecker/_share.sml +++ b/src/typechecker/_share.sml @@ -165,9 +165,10 @@ functor Share( * occur later in the structure's type name list. *) - val share_failures = ref [] - val old_share_failures = ref [] - val failure_reasons = ref [] + type failures = IdentPrint.Ident.TyCon list ref + val share_failures : failures = ref [] + val old_share_failures : failures = ref [] + val failure_reasons : string list ref = ref [] (**** Handles the sharing of types present in two structures being shared. diff --git a/src/unix/__time.sml b/src/unix/__time.sml index c88e51b2..59a79464 100644 --- a/src/unix/__time.sml +++ b/src/unix/__time.sml @@ -82,7 +82,7 @@ structure Time : TIME = datatype time = datatype MLWorks.Internal.Types.time exception Time - val timeRef = env "Time.Time" + val timeRef = (env "Time.Time"):exn ref val _ = timeRef := Time val zeroTime = TIME (0, 0, 0) diff --git a/src/unix/_unixos.sml b/src/unix/_unixos.sml index 5749870b..4cfd15ac 100644 --- a/src/unix/_unixos.sml +++ b/src/unix/_unixos.sml @@ -172,7 +172,7 @@ struct end exception WouldBlock - val would_block_ref = env "system os unix exception Would Block" + val would_block_ref = (env "system os unix exception Would Block"):exn ref val _ = would_block_ref := WouldBlock datatype sockaddr = SOCKADDR_UNIX of string diff --git a/src/utils/__messages.sml b/src/utils/__messages.sml index 4515c0fd..9d9f5dd9 100644 --- a/src/utils/__messages.sml +++ b/src/utils/__messages.sml @@ -37,6 +37,6 @@ require "messages"; structure Messages : MESSAGES = struct fun env s = MLWorks.Internal.Value.cast(MLWorks.Internal.Runtime.environment s) - val output = env"stream message output" - val flush = env"stream message flush" + val output : string -> unit = env"stream message output" + val flush : unit -> unit = env"stream message flush" end;