1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
open St_ast
module M = St_memory
module C = St_class
module I = St_interp
exception Error of string
let quiet_host : I.host =
{
transcript = (fun _ -> ());
milliseconds = (fun () -> int_of_float (Sys.time () *. 1000.));
inspect = (fun _ -> ());
mouse = (fun () -> (0, 0, 0));
}
let class_named (m : M.t) (name : string) : M.oop =
match C.global m name with Some a -> M.fetch m a 1 | None -> raise (Error ("no class " ^ name))
type definition = { sup : string; name : string; kind : C.kind; ivs : string list; cvs : string list; cat : string }
let words (s : string) : string list =
String.split_on_char ' ' s |> List.concat_map (String.split_on_char '\t') |> List.concat_map (String.split_on_char '\n')
|> List.filter (( <> ) "")
let definition (text : string) : definition option =
match St_parse.parse_doit text with
| {
body =
[
Expr
{
e =
Send
( { e = Var sup; _ },
sel,
[ { e = Lit (L_symbol name); _ }; { e = Lit (L_string ivs); _ }; { e = Lit (L_string cvs); _ }; _; { e = Lit (L_string cat); _ } ] );
_;
};
];
_;
} -> (
let kind =
match (name, sel) with
| "Float", _ -> Some C.Float_kind
| "CompiledMethod", _ -> Some C.Method_kind
| _, "subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:" -> Some C.Fixed
| _, "variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:" -> Some C.Indexable
| _, "variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:" -> Some C.Byte_indexable
| _ -> None
in
match kind with Some kind -> Some { sup; name; kind; ivs = words ivs; cvs = words cvs; cat } | None -> None)
| _ -> None
| exception St_parse.Error _ -> None
let line_of (text : string) (pos : int) : int =
let n = ref 1 in
String.iteri (fun i c -> if i < pos && c = '\n' then incr n) text;
!n
let boot ?(host = quiet_host) ?(kernel = St_kernel.files) () : I.vm =
let m = M.create () in
let k = M.known m in
let items = List.concat_map (fun (file, text) -> List.map (fun i -> (file, text, i)) (St_chunk.read text)) kernel in
let defs =
List.filter_map (fun (_, _, i) -> match i with St_chunk.Doit (t, _) -> definition t | St_chunk.Methods _ -> None) items
in
let defs =
let last name = List.find (fun d -> d.name = name) (List.rev defs) in
let rec go seen = function
| [] -> []
| d :: rest -> if List.mem d.name seen then go seen rest else last d.name :: go (d.name :: seen) rest
in
go [] defs
in
let table = Hashtbl.create 64 in
let metas =
List.map
(fun d ->
let meta = M.alloc m ~cls:M.nil (M.Pointers (Array.make 6 M.nil)) in
let cls = M.alloc m ~cls:meta (M.Pointers (Array.make 9 M.nil)) in
Hashtbl.replace table d.name cls;
meta)
defs
in
let get n = match Hashtbl.find_opt table n with Some c -> c | None -> raise (Error ("the kernel defines no " ^ n)) in
k.metaclass <- get "Metaclass";
List.iter (fun meta -> M.set_class m meta k.metaclass) metas;
k.small_integer <- get "SmallInteger";
k.string <- get "String";
k.symbol <- get "Symbol";
k.array <- get "Array";
k.float <- get "Float";
k.character <- get "Character";
k.compiled_method <- get "CompiledMethod";
k.method_context <- get "MethodContext";
k.block_context <- get "BlockContext";
k.block_closure <- Option.value (Hashtbl.find_opt table "BlockClosure") ~default:M.nil;
k.message <- get "Message";
k.association <- get "Association";
k.point <- get "Point";
k.large_positive <- get "LargePositiveInteger";
k.large_negative <- get "LargeNegativeInteger";
k.method_dictionary <- get "MethodDictionary";
M.set_class m M.nil (get "UndefinedObject");
k.true_ <- M.alloc m ~cls:(get "True") (M.Pointers [||]);
k.false_ <- M.alloc m ~cls:(get "False") (M.Pointers [||]);
k.characters <- Array.init 256 (fun i -> M.alloc m ~cls:k.character (M.Pointers [| M.of_int i |]));
k.smalltalk <- M.alloc m ~cls:(get "SystemDictionary") (M.Pointers [| M.new_array m [||] |]);
k.special_selectors <- Array.map (M.symbol m) St_bytecode.special_selectors;
ignore (C.declare_global m "Smalltalk" k.smalltalk);
List.iter (fun d -> ignore (C.declare_global m d.name (get d.name))) defs;
List.iter
(fun d ->
let superclass = if d.sup = "nil" then M.nil else get d.sup in
ignore (C.define_class m ~superclass ~name:d.name ~kind:d.kind ~inst_vars:d.ivs ~class_vars:d.cvs ~category:d.cat))
defs;
List.iter
(fun (file, text, item) ->
match item with
| St_chunk.Methods { class_name; meta; category; methods } ->
let cls = get class_name in
let cls = if meta then M.class_of m cls else cls in
List.iter
(fun (src, pos) ->
try ignore (St_compile.compile_and_install m ~cls ~category ~declare:true src)
with St_compile.Error (p, msg) ->
raise (Error (Printf.sprintf "%s:%d: %s>>%s" file (line_of text (pos + p)) (C.name m cls) msg)))
methods
| St_chunk.Doit _ -> ())
items;
let vm = I.create m host in
St_primitives.install vm;
List.iter
(fun (file, text, item) ->
match item with
| St_chunk.Doit (src, pos) when definition src = None -> (
let empty = match St_parse.parse_doit src with { body = []; _ } -> true | _ -> false | exception St_parse.Error _ -> false in
if not empty then
match I.evaluate vm src with
| Ok _ -> ()
| Error msg -> raise (Error (Printf.sprintf "%s:%d: %s" file (line_of text pos) msg)))
| _ -> ())
items;
vm