diff --git a/src/make/change_nj.sml b/src/make/change_nj.sml new file mode 100644 index 00000000..b2e51184 --- /dev/null +++ b/src/make/change_nj.sml @@ -0,0 +1,1841 @@ +(* ==== 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 = + (fn SOME #" " => use ("../pervasive/" ^ String.substring (s, 1, size s - 1) ^ ".sml") + | _ => use ("../pervasive/" ^ s ^ ".sml")) (Char.fromString s); + +type word = int; + +nonfix quot rem; + +require "mlworks"; + +exception Unimplemented of string +fun unimplemented name = + (output (std_out, "unimplemented MLWorks pervasive: " ^ name ^ "\n"); + raise Unimplemented name) + +structure MLWorks : MLWORKS = + struct + + structure Option = + struct + datatype 'a option = SOME of 'a | NONE + datatype ('a,'b) union = INL of 'a | INR of 'b + end + + structure Bits = + struct + open NewJersey.Bits + fun arshift _ = unimplemented "MLWorks.Bits.arshift" + end + + structure Vector = + struct + datatype 'a vector = Vector of 'a list + + exception Size + exception Subscript + + nonfix sub + + val vector = Vector + + fun tabulate (i, f) = + let fun tab j = if j < i then f j :: tab (j+1) else nil + in if i < 0 then raise Size else Vector (tab 0) + end + + fun sub (Vector nil, i) = raise Subscript + | sub (Vector (a::r), i) = + if i > 0 then sub (Vector r, i-1) + else if i < 0 then raise Subscript + else a + + fun length (Vector nil) = 0 + | length (Vector (a::r)) = 1 + length (Vector r) + end + + structure Array = + struct + open NewJersey.Array + type 'a T = 'a array + end + + structure ExtendedArray = + struct + open NewJersey.Array + + nonfix sub + type 'a T = 'a array + + fun tabulate (l, f) = + if l = 0 then + arrayoflist [] + else + let + val first = f 0 + val a = array (l, first) + + fun init 0 = a + | init n = + (update (a, n-l, f (n-l)); + init (n-1)) + in + init (l-1) + end + + val from_list = arrayoflist + + fun fill (a, x) = + let + fun fill' 0 = () + | fill' n = + (update (a, n-1, x); + fill' (n-1)) + in + fill' (length a) + end + + fun map f a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = f (sub (a, 0)) + val new = array (l, first) + + fun map' 0 = new + | map' n = + (update (new, l-n, f (sub (a, l-n))); + map' (n-1)) + in + map' (l-1) + end + end + + fun map_index f a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = f (0, sub (a, 0)) + val new = array (l, first) + + fun map' 0 = new + | map' n = + (update (new, l-n, f (l-n, sub (a, l-n))); + map' (n-1)) + in + map' (l-1) + end + end + + fun to_list a = + let + fun to_list' (0, list) = list + | to_list' (n, list) = + to_list' (n-1, sub (a, n-1) :: list) + in + to_list' (length a, nil) + end + + fun iterate f a = + let + val l = length a + + fun iterate' 0 = () + | iterate' n = + (f (sub (a, l-n)); + iterate' (n-1)) + in + iterate' l + end + + fun iterate_index f a = + let + val l = length a + + fun iterate' 0 = () + | iterate' n = + (f (l-n, sub (a, l-n)); + iterate' (n-1)) + in + iterate' l + end + + fun rev a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = sub (a, 0) + val new = array (l, first) + + fun rev' 0 = new + | rev' n = + (update (new, n-1, sub (a, l-n)); + rev' (n-1)) + in + rev' (l-1) + end + end + + fun duplicate a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = sub (a, 0) + val new = array (l, first) + + fun duplicate' 0 = new + | duplicate' n = + (update (new, l-n, sub (a, l-n)); + duplicate' (n-1)) + in + duplicate' (l-1) + end + end + + exception Subarray of int * int + fun subarray (a, start, finish) = + let + val l = length a + in + if start < 0 orelse start > l orelse finish > l orelse + start > finish then + raise Subarray (start, finish) + else + let + val l' = finish - start + in + if l' = 0 then + from_list [] + else + let + val first = sub (a, start) + val new = array (l', first) + + fun copy 0 = new + | copy n = + (update (new, l'-n, sub (a, start+l'-n)); + copy (n-1)) + in + copy (l'-1) + end + end + end + + fun append (array1, array2) = + let + val l1 = length array1 + val l2 = length array2 + val l = l1 + l2 + in + if l = 0 then + from_list [] + else + let + val first = + if l1 = 0 then + sub (array2, 0) + else + sub (array1, 0) + + val new = array (l, first) + + fun copy1 0 = new + | copy1 n = + (update (new, l1-n, sub (array1, l1-n)); + copy1 (n-1)) + + fun copy2 0 = copy1 (l1-1) + | copy2 n = + (update (new, l-n, sub (array2, l2-n)); + copy2 (n-1)) + in + copy2 l2 + end + end + + fun reducel f (i, a) = + let + val l = length a + + fun reducel' (i, 0) = i + | reducel' (i, n) = + reducel' (f (i, sub (a, l-n)), n-1) + in + reducel' (i, l) + end + + fun reducel_index f (i, a) = + let + val l = length a + + fun reducel' (i, 0) = i + | reducel' (i, n) = + reducel' (f (l-n, i, sub (a, l-n)), n-1) + in + reducel' (i, l) + end + + fun reducer f (a, i) = + let + val l = length a + + fun reducer' (0, i) = i + | reducer' (n, i) = + reducer' (n-1, f (sub (a, n-1), i)) + in + reducer' (l, i) + end + + fun reducer_index f (a, i) = + let + val l = length a + + fun reducer' (0, i) = i + | reducer' (n, i) = + reducer' (n-1, f (n-1, sub (a, n-1), i)) + in + reducer' (l, i) + end + + exception Copy of int * int * int + fun copy (from, start, finish, to, start') = + let + val l1 = length from + val l2 = length to + in + if start < 0 orelse start > l1 orelse finish > l1 orelse + start > finish orelse + start' < 0 orelse start' + finish - start > l2 then + raise Copy (start, finish, start') + else + let + fun copy' 0 = () + | copy' n = + (update (to, start'+n-1, sub (from, start+n-1)); + copy' (n-1)) + in + copy' (finish - start) + end + end + + exception Fill of int * int + fun fill_range (a, start, finish, x) = + let + val l = length a + in + if start < 0 orelse start > l orelse finish > l orelse + start > finish then + raise Fill (start, finish) + else + let + fun fill' 0 = () + | fill' n = + (update (a, start+n-1, x); + fill' (n-1)) + in + fill' (finish - start) + end + end + + exception Find + fun find predicate a = + let + val l = length a + fun find' 0 = raise Find + | find' n = if predicate (sub (a, l-n)) then l-n else find' (n-1) + in + find' l + end + + fun find_default (predicate, default) a = + let + val l = length a + fun find' 0 = default + | find' n = if predicate (sub (a, l-n)) then l-n else find' (n-1) + in + find' l + end + + end + + structure String = + struct + fun ml_string (s,max_size) = + let + fun to_digit n = chr (n +ord "0") + + fun aux ([],result,_) = implode (rev result) + | aux (_,result,0) = implode (rev ("\\..." :: result)) + | aux (char::rest,result,n) = + let val newres = + case char of + "\n" => "\\n"::result + | "\t" => "\\t"::result + | "\"" => "\\\""::result + | "\\" => "\\\\"::result + | c => + let val n = ord c + in + if n < 32 orelse 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 (explode s,[],if max_size<0 then ~1 else max_size) + end + open NewJersey.String + + fun implode_char l = implode (map chr l) + + end + + structure Char = + struct + type char = int + fun ml_char c = String.ml_string(chr c, ~1) + val chr = fn x => x + val ord = fn x => x + 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 ByteArray = + struct + open NewJersey.ByteArray + + exception Range of int + exception Size + + nonfix sub + type T = bytearray + + val iterate = app + + val array = fn argument => + array argument handle Ord => raise Size + + exception Substring = NewJersey.Substring + fun substring argument = + extract argument handle _ => raise Substring + + fun to_string b = extract (b, 0, length b) + + fun from_string s = + let + val l = size s + val b = array (l, 0) + fun from_string' 0 = b + | from_string' n = + (update (b, n-1, NewJersey.String.ordof (s, n-1)); + from_string' (n-1)) + in + from_string' l + end + + fun from_list list = + let + fun list_length (n, []) = n + | list_length (n, _::xs) = list_length (n+1, xs) + + val new = array (list_length (0, list), 0) + + fun fill (_, []) = new + | fill (n, x::xs) = + (update (new, n, x); + fill (n+1, xs)) + in + fill (0, list) + end + + val arrayoflist = from_list + + fun tabulate (l, f) = + if l = 0 then + arrayoflist [] + else + let + val first = f 0 + val a = array (l, first) + + fun init 0 = a + | init n = + (update (a, n-l, f (n-l)); + init (n-1)) + in + init (l-1) + end + + val from_list = arrayoflist + + fun fill (a, x) = + let + fun fill' 0 = () + | fill' n = + (update (a, n-1, x); + fill' (n-1)) + in + fill' (length a) + end + + fun map f a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = f (sub (a, 0)) + val new = array (l, first) + + fun map' 0 = new + | map' n = + (update (new, l-n, f (sub (a, l-n))); + map' (n-1)) + in + map' (l-1) + end + end + + fun map_index f a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = f (0, sub (a, 0)) + val new = array (l, first) + + fun map' 0 = new + | map' n = + (update (new, l-n, f (l-n, sub (a, l-n))); + map' (n-1)) + in + map' (l-1) + end + end + + fun to_list a = + let + fun to_list' (0, list) = list + | to_list' (n, list) = + to_list' (n-1, sub (a, n-1) :: list) + in + to_list' (length a, nil) + end + + fun iterate f a = + let + val l = length a + + fun iterate' 0 = () + | iterate' n = + (f (sub (a, l-n)); + iterate' (n-1)) + in + iterate' l + end + + fun iterate_index f a = + let + val l = length a + + fun iterate' 0 = () + | iterate' n = + (f (l-n, sub (a, l-n)); + iterate' (n-1)) + in + iterate' l + end + + fun rev a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = sub (a, 0) + val new = array (l, first) + + fun rev' 0 = new + | rev' n = + (update (new, n-1, sub (a, l-n)); + rev' (n-1)) + in + rev' (l-1) + end + end + + fun duplicate a = + let + val l = length a + in + if l = 0 then + from_list [] + else + let + val first = sub (a, 0) + val new = array (l, first) + + fun duplicate' 0 = new + | duplicate' n = + (update (new, l-n, sub (a, l-n)); + duplicate' (n-1)) + in + duplicate' (l-1) + end + end + + exception Subarray of int * int + fun subarray (a, start, finish) = + let + val l = length a + in + if start < 0 orelse start > l orelse finish > l orelse + start > finish then + raise Subarray (start, finish) + else + let + val l' = finish - start + in + if l' = 0 then + from_list [] + else + let + val first = sub (a, start) + val new = array (l', first) + + fun copy 0 = new + | copy n = + (update (new, l'-n, sub (a, start+l'-n)); + copy (n-1)) + in + copy (l'-1) + end + end + end + + fun append (array1, array2) = + let + val l1 = length array1 + val l2 = length array2 + val l = l1 + l2 + in + if l = 0 then + from_list [] + else + let + val first = + if l1 = 0 then + sub (array2, 0) + else + sub (array1, 0) + + val new = array (l, first) + + fun copy1 0 = new + | copy1 n = + (update (new, l1-n, sub (array1, l1-n)); + copy1 (n-1)) + + fun copy2 0 = copy1 (l1-1) + | copy2 n = + (update (new, l-n, sub (array2, l2-n)); + copy2 (n-1)) + in + copy2 l2 + end + end + + fun reducel f (i, a) = + let + val l = length a + + fun reducel' (i, 0) = i + | reducel' (i, n) = + reducel' (f (i, sub (a, l-n)), n-1) + in + reducel' (i, l) + end + + fun reducel_index f (i, a) = + let + val l = length a + + fun reducel' (i, 0) = i + | reducel' (i, n) = + reducel' (f (l-n, i, sub (a, l-n)), n-1) + in + reducel' (i, l) + end + + fun reducer f (a, i) = + let + val l = length a + + fun reducer' (0, i) = i + | reducer' (n, i) = + reducer' (n-1, f (sub (a, n-1), i)) + in + reducer' (l, i) + end + + fun reducer_index f (a, i) = + let + val l = length a + + fun reducer' (0, i) = i + | reducer' (n, i) = + reducer' (n-1, f (n-1, sub (a, n-1), i)) + in + reducer' (l, i) + end + + exception Copy of int * int * int + fun copy (from, start, finish, to, start') = + let + val l1 = length from + val l2 = length to + in + if start < 0 orelse start > l1 orelse finish > l1 orelse + start > finish orelse + start' < 0 orelse start' + finish - start > l2 then + raise Copy (start, finish, start') + else + let + fun copy' 0 = () + | copy' n = + (update (to, start'+n-1, sub (from, start+n-1)); + copy' (n-1)) + in + copy' (finish - start) + end + end + + exception Fill of int * int + fun fill_range (a, start, finish, x) = + let + val l = length a + in + if start < 0 orelse start > l orelse finish > l orelse + start > finish then + raise Fill (start, finish) + else + let + fun fill' 0 = () + | fill' n = + (update (a, start+n-1, x); + fill' (n-1)) + in + fill' (finish - start) + end + end + + exception Find + fun find predicate a = + let + val l = length a + fun find' 0 = raise Find + | find' n = if predicate (sub (a, l-n)) then l-n else find' (n-1) + in + find' l + end + + fun find_default (predicate, default) a = + let + val l = length a + fun find' 0 = default + | find' n = if predicate (sub (a, l-n)) then l-n else find' (n-1) + in + find' l + end + + end + + structure Integer = + struct + val makestring : int -> string = makestring + val print : int -> unit = fn i => output(std_out, makestring i) + fun hexmakestring _ = unimplemented"hexmakestring" + fun hexprint _ = unimplemented"hexprint" + end + + structure Real = + struct + val makestring : real -> string = makestring + val print : real -> unit = fn r => output(std_out, makestring r) + end + + structure Time = + struct + + type time = NewJersey.System.Timer.time + val zero = NewJersey.System.Timer.TIME {sec=0, usec=0} + + structure Interval = + struct + type T = time + fun to_real _ = unimplemented "MLWorks.Time.Interval.to_real" + fun from_real _ = unimplemented "MLWorks.Time.Interval.from_real" + + val op+ = NewJersey.System.Timer.add_time + val op- = NewJersey.System.Timer.sub_time + fun x*y = unimplemented "MLWorks.Time.Interval.*" + fun x/y = unimplemented "MLWorks.Time.Interval./" + val op< = NewJersey.System.Timer.earlier + val decimal_places = ref 2 + val format = NewJersey.System.Timer.makestring + end + + structure Elapsed = + struct + datatype T = ELAPSED of {real: Interval.T, + user: Interval.T, + system: Interval.T, + gc: Interval.T} + val zero = ELAPSED {real=zero, + user=zero, + system=zero, + gc=zero} + fun elapsed () = zero + fun elapsed_since _ = zero + fun x+y = unimplemented "MLWorks.Time.Elapsed.+" + fun x-y = unimplemented "MLWorks.Time.Elapsed.-" + fun x*y = unimplemented "MLWorks.Time.Elapsed.*" + fun x/y = unimplemented "MLWorks.Time.Elapsed./" + fun format _ = "" + end + + fun now _ = unimplemented "MLWorks.Time.now" + val op< = NewJersey.System.Timer.earlier + + fun interval _ = unimplemented "MLWorks.Time.interval" + + datatype zone = GREENWICH | LOCAL + fun format (_, _, time) = NewJersey.System.Timer.makestring time + + (* This must encoded times in the same way as *) + (* rts/pervasive/time.c and rts/marshal.c *) + exception MLWorksTimeEncode + + fun encode (NewJersey.System.Timer.TIME {sec, usec}) = + let + fun marshal_ints [] = [] + | marshal_ints (x::xs) = + if x >= 128 then + chr ((x mod 128)+128) :: marshal_ints ((x div 128)::xs) + else + chr x :: (marshal_ints xs) + in + implode (marshal_ints [sec,usec]) + end + + fun decode s = + let + fun unmarshal_int (acc,s, []) = raise MLWorksTimeEncode + | unmarshal_int (acc,s, c::cs) = + let + val i = ord c + in + if i >= 128 then + unmarshal_int (acc+ ((i mod 128) * s), + s*128, cs) + else + (acc+(i * s),cs) + end + val (sec,s') = unmarshal_int (0,1,explode s) + val (usec,_) = unmarshal_int (0,1,s') + in + NewJersey.System.Timer.TIME {sec = sec,usec = usec} + end + + val op+ = NewJersey.System.Timer.add_time + val op- = NewJersey.System.Timer.sub_time + end + + structure Threads = + struct + type 'a thread = unit + + fun fork _ = unimplemented "MLWorks.Threads.fork" + 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 _ = unimplemented "MLWorks.Threads.result" + 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" + fun get_num _ = unimplemented "MLWorks.Threads.Internal.get_num" + 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" + fun get_interval _ = unimplemented "MLWorks.Threads.Internal.Preemption.get_interval" + fun set_interval _ = unimplemented "MLWorks.Threads.Internal.Preemption.set_interval" + end + end + end + + structure RawIO = + struct + open NewJersey (* types instream, outstream, + values std_in, std_out, std_err, open_in, open_out, end_of_stream, input, + lookahead, output, close_in, close_out *) + + fun output_byte(fd, byte) = output(fd, chr byte) + + fun closed_in _ = unimplemented "MLWorks.IO.closed_in" + fun closed_out _ = unimplemented "MLWorks.IO.closed_out" + fun clear_eof _ = unimplemented "MLWorks.IO.clear_eof" + end + + structure IO = + struct + open RawIO + val terminal_in = std_in + fun with_standard_input _ = unimplemented "MLWorks.IO.with_standard_input" + val terminal_out = std_out + val messages = std_err + fun instream _ = std_in + fun outstream _ = std_out + fun with_standard_output _ = unimplemented "MLWorks.IO.with_standard_output" + fun with_standard_error _ = unimplemented "MLWorks.IO.with_standard_error" + datatype modtime = NOW | TIME of Time.time + + fun file_modified filename = + NewJersey.System.Unsafe.SysIO.mtime + (NewJersey.System.Unsafe.SysIO.PATH filename) + handle _ => raise Io (implode ["Cannot mtime ", filename, ": doesn't exist"]) + + fun set_file_modified _ = unimplemented "MLWorks.IO.set_file_modified"; + + 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: Time.Interval.T, + suspended: Time.Interval.T} + + 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" + + fun make_manner {time, space, copies, calls, depth, breakdown} = + unimplemented "MLWorks.Profile.make_manner" + + end + + exception Save of string + fun save (filename, function) = + (NewJersey.exportFn (filename, fn _ => (function (); ())); + function) + + fun deliver _ = unimplemented "MLWorks.deliver" + + fun exec_save _ = unimplemented "MLWorks.exec_save" + + structure OS = + struct + fun arguments () = + case NewJersey.System.argv () + of [] => [] + | program_name::rest => rest + end + + structure Debugger = + struct + fun default_break s = IO.output(IO.std_out,"Break at " ^ s ^ "\n") + val break_hook = ref default_break + fun break s = (!break_hook) s + end + + structure Internal = + struct + val text_preprocess = ref (fn (f : int -> string ) => f) + val real_to_string = NewJersey.makestring + + exception StringToReal + + fun string_to_real chars = + let + exception too_small + exception too_big + fun getint str = + let + fun convert res [] = res + | convert res (h :: t) = + let + val d = ord h - ord "0" + in + if d >= 0 andalso d <= 9 then + convert (res * 10 + d) t + else + raise StringToReal + end + in + convert 0 str + end + + fun decode_real x = + let + val string_chars = explode x + val (sign, string_chars) = case string_chars of + [] => raise StringToReal + | "~" :: xs => (true, xs) + | _ => (false, string_chars) + val (integer, fraction, exponent) = + let + fun find_point_exp(integer, fraction, exponent, _, _, []) = + (rev integer, rev fraction, rev exponent) + | find_point_exp(integer, fraction, exponent, got_point, got_exp, + "." :: xs) = + find_point_exp(integer, [], [], true, false, xs) + | find_point_exp(integer, fraction, exponent, got_point, got_exp, + "E" :: xs) = + find_point_exp(integer, fraction, [], true, true, xs) + | find_point_exp(integer, fraction, exponent, got_point, got_exp, + x :: xs) = + if got_exp then + find_point_exp(integer, fraction, x :: exponent, true, true, xs) + else + if got_point then + find_point_exp(integer, x :: fraction, [], true, false, xs) + else + find_point_exp(x :: integer, [], [], false, false, xs) + in + find_point_exp([], [], [], false, false, string_chars) + end + val (exponent_sign, exponent) = case exponent of + [] => (false, ["0"]) + | "~" :: xs => (true, xs) + | _ => (false, exponent) + val integer = integer @ fraction + val exponent = + getint exponent + handle _ => raise(if exponent_sign then too_small else too_big) + val exponent = + (if exponent_sign then ~exponent else exponent) - length fraction + in + (sign, integer, exponent < 0, abs exponent) + end + + + val (sign, floor, exp_sign, exponent) = decode_real chars + + fun floor_to_real([], result) = result + | floor_to_real(x :: xs, result) = + floor_to_real(xs, 10.0 * result + real(ord(x) - ord"0")) + val r = floor_to_real(floor, 0.0) + + fun apply_exponent(r, sign, exponent) = + if exponent = 0 then r + else + let + val conv = real exponent * ln 10.0 + val conv = if sign then ~conv else conv + in + r * exp conv handle _ => raise(if sign then too_small else too_big) + end + val r = apply_exponent(r, exp_sign, exponent) + in + if sign then ~r else r + end + + 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 = int + type int8 = int + type word16 = int + type int16 = int + type word32 = int + type int32 = int + end + + structure Word = + struct + type word = int + local + open NewJersey.Bits + in + val word_lshift : word * word -> word = lshift + val word_rshift : word * word -> word = rshift + val word_arshift : word * word -> word = + fn _ => unimplemented "MLWorks.Word.arshift" + val word_orb : word * word -> word = orb + val word_xorb : word * word -> word = xorb + val word_andb : word * word -> word = andb + val word_notb : word -> word = notb + end + end + + structure Word32 = + struct + type word = int + local + open NewJersey.Bits + in + val word32_lshift : word * word -> word = lshift + val word32_rshift : word * word -> word = rshift + val word32_arshift : word * word -> word = + fn _ => unimplemented "MLWorks.Word.arshift" + val word32_orb : word * word -> word = orb + val word32_xorb : word * word -> word = xorb + val word32_andb : word * word -> word = andb + val word32_notb : word -> word = notb + end + end + + structure Value = + struct + type T = unit + type ml_value = T + exception Value of string + val cast = NewJersey.System.Unsafe.cast + val ccast = NewJersey.System.Unsafe.cast + datatype print_options = + DEFAULT | + OPTIONS of {depth_max : int, + string_length_max : int, + indent : bool, + tags : bool} + + fun unsafe_plus _ = unimplemented "MLWorks.Internal.Value.unsafe_plus" + fun unsafe_minus _ = unimplemented "MLWorks.Internal.Value.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 + + fun unsafe_record_sub _ = unimplemented "MLWorks.Internal.Value.unsafe_record_sub" + fun unsafe_record_update _ = unimplemented "MLWorks.Internal.Value.unsafe_record_update" + + fun unsafe_string_sub _ = unimplemented "MLWorks.Internal.Value.unsafe_string_sub" + fun unsafe_string_update _ = unimplemented "MLWorks.Internal.Value.unsafe_string_update" + + fun alloc_pair _ = unimplemented "MLWorks.Internal.Value.alloc_pair" + fun alloc_string _ = unimplemented "MLWorks.Internal.Value.alloc_string" + fun alloc_vector _ = unimplemented "MLWorks.Internal.Value.alloc_vector" + + fun list_to_tuple _ = unimplemented "MLWorks.Internal.Value.list_to_tuple" + fun tuple_to_list _ = unimplemented "MLWorks.Internal.Value.tuple_to_list" + fun string_to_real _ = unimplemented "MLWorks.Internal.Value.string_to_real" + fun real_to_string _ = unimplemented "MLWorks.Internal.Value.real_to_string" + fun print _ = unimplemented "MLWorks.Internal.Value.print" + fun primary _ = unimplemented "MLWorks.Internal.Value.primary" + fun header _ = unimplemented "MLWorks.Internal.Value.secondary" + fun update_header _ = unimplemented "MLWorks.Internal.Value.update_header" + fun pointer _ = unimplemented "MLWorks.Internal.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" + 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" + + structure Frame = + struct + type frame = unit + + fun frame_call _ = unimplemented "MLWorks.Internal.Value.Frame.frame_call" + fun frame_next _ = unimplemented "MLWorks.Internal.Value.Frame.frame_next" + 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" + fun is_ml_frame _ = unimplemented "MLWorks.Internal.Value.Frame.is_ml_frame" + 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 + fun status _ = unimplemented "MLWorks.Internal.Trace.status" + 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 FileIO = + struct + type fd = NewJersey.System.Unsafe.SysIO.fd * NewJersey.ByteArray.bytearray * int ref + datatype offset = BEG | CUR | END + + fun flush (fd, buffer, bp) = + (NewJersey.System.Unsafe.SysIO.write(fd, buffer, !bp); bp := 0) + + fun openf s = + (NewJersey.System.Unsafe.SysIO.openf(s, NewJersey.System.Unsafe.SysIO.O_WRITE), + NewJersey.ByteArray.array (4096, 0), ref 0) + + (* 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 (f as (fd, _, _)) = + (flush f; + NewJersey.System.Unsafe.CInterface.wrap_sysfn + "fsync" + NewJersey.System.Unsafe.CInterface.syscall + (95,[NewJersey.System.Unsafe.cast fd]); + NewJersey.System.Unsafe.SysIO.closef fd) + + fun seekf (f as (fd, _, _), i, p) = + let + val pos = case p of + BEG => NewJersey.System.Unsafe.SysIO.L_SET + | CUR => NewJersey.System.Unsafe.SysIO.L_INCR + | END => NewJersey.System.Unsafe.SysIO.L_XTND + in + flush f; NewJersey.System.Unsafe.SysIO.lseek (fd, i, pos); () + end + + fun writebf (f as (fd, _, _), bytearray, start, length) = + (flush f; NewJersey.System.Unsafe.SysIO.writei (fd, bytearray, start, length)) + + fun writef ((fd, buffer, bp), s) = + let + val sz = size s + + fun copy (x, ptr) = + if x > 4095 then + (NewJersey.System.Unsafe.SysIO.write(fd, buffer, 4096); copy(0, ptr)) + else + if ptr < sz then + (NewJersey.ByteArray.update(buffer, x, NewJersey.String.ordof(s,ptr)); copy(x+1, ptr+1)) + else + (bp := x) + in + copy(!bp, 0) + end + + fun write_byte(fd, byte) = writef(fd, chr byte) + end + + structure Runtime = + struct + exception Unbound of string + val environment = Value.cast o nj_environment (* Defined in nj_env.sml *) + + val modules = ref ([] : (string * Value.T * Time.time) list) + + structure Loader = + struct + exception Load of string + fun load_module _ = unimplemented "MLWorks.Internal.Runtime.Loader.load_module" + 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" + 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 Bits = NewJersey.Bits; +structure OldNewJersey = NewJersey; +structure NewJersey = struct end; diff --git a/src/make/nj_env.sml b/src/make/nj_env.sml index 03331c0d..0f30ac1f 100644 --- a/src/make/nj_env.sml +++ b/src/make/nj_env.sml @@ -14,18 +14,21 @@ local (* A handful of environment functions that we need *) (* We only need the functions that actually get called by the compiler here *) - val environment = NewJersey.System.environ - val setwd = System.Directory.cd - val getwd = NewJersey.System.Directory.getWD - fun realpath (s: string) :string = - NewJersey.System.Unsafe.CInterface.c_function - "realpath" - (NewJersey.System.Unsafe.CInterface.c_string s) - handle NewJersey.System.Unsafe.CInterface.SysError _ => - raise Io ("realpath: " ^ s) + (* http://www.standardml.org/Basis/os-process.html#SIG:OS_PROCESS.getEnv:VAL *) + val environment = OS.Process.getEnv + + (* 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 + + (* http://www.smlnj.org/doc/SMLofNJ/pages/unsafe.html#SIG:UNSAFE.cast:VAL *) type T = int ref - val tcast : 'a -> T = NewJersey.System.Unsafe.cast + val tcast : 'a -> T = Unsafe.cast val env_refs = ref [] : (string * T) list ref @@ -41,7 +44,7 @@ local exception UnimplementedEnv of string fun unimplemented name = - (output (std_out, "unimplemented env function: " ^ name ^ "\n"); + (TextIO.output (TextIO.stdOut, "unimplemented env function: " ^ name ^ "\n"); raise UnimplementedEnv name) in 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..cdb7cc63 --- /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 = int + 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