├── lib_telnet ├── telnet.ml ├── telnet.mli ├── wire.ml └── server.ml ├── stories └── MiniZork.Z3 ├── _tags ├── lib ├── flathead.ml ├── globals.ml ├── randomness.ml ├── immutable_bytes.ml ├── evaluation_stack.ml ├── routine.ml ├── status_line.ml ├── transcript.ml ├── frameset.ml ├── runner.ml ├── compression.ml ├── local_store.ml ├── reachability.ml ├── dictionary.ml ├── quetzal.ml ├── deque.ml ├── frame.ml ├── zstring.ml ├── type.ml ├── tokeniser.ml ├── screen.ml ├── utility.ml ├── window.ml ├── iff.ml ├── object.ml ├── instruction.ml └── story.ml ├── config.ml ├── .gitignore ├── README.md └── unikernel.ml /lib_telnet/telnet.ml: -------------------------------------------------------------------------------- 1 | module Server = Server 2 | -------------------------------------------------------------------------------- /stories/MiniZork.Z3: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mato/flathead/HEAD/stories/MiniZork.Z3 -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: bin_annot 2 | "lib": include 3 | "lib_telnet": include 4 | 5 | : package(ppx_cstruct sexplib) 6 | -------------------------------------------------------------------------------- /lib_telnet/telnet.mli: -------------------------------------------------------------------------------- 1 | 2 | module Server : sig 3 | type state 4 | 5 | val handle : state -> Cstruct.t -> 6 | (state * [ `Data of Cstruct.t | `Resize of int * int ] list * Cstruct.t) 7 | 8 | val init : unit -> (state * Cstruct.t) 9 | 10 | val encode : Cstruct.t -> Cstruct.t 11 | end 12 | -------------------------------------------------------------------------------- /lib/flathead.ml: -------------------------------------------------------------------------------- 1 | open Type;; 2 | let story = Story.load "MiniZork.Z3" ;; 3 | let screen = Screen.make (Character_height 50) (Character_width 80) ;; 4 | let interpreter = Interpreter.make story screen ;; 5 | let runner = Runner.make interpreter ;; 6 | Runner.run runner ;; 7 | (* let debugger = Debugger.make interpreter ;; 8 | Debugger.run debugger ;; *) 9 | -------------------------------------------------------------------------------- /config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let port = 4 | let doc = Key.Arg.info ~doc:"The TCP listen port." ["port"] in 5 | Key.(create "port" Arg.(opt int 23 doc)) 6 | 7 | let stories = generic_kv_ro "stories" 8 | 9 | let main = 10 | let packages = [ package "logs" ] in 11 | let keys = [ Key.abstract port; ] in 12 | foreign 13 | ~keys ~packages 14 | "Unikernel.Main" (kv_ro @-> stackv4 @-> job) 15 | 16 | let stack = generic_stackv4 default_network 17 | 18 | let () = register "flathead" [main $ stories $ stack ] 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | *.DAT 11 | *.sav 12 | 13 | # ocamlbuild working directory 14 | _build/ 15 | 16 | # ocamlbuild targets 17 | *.byte 18 | *.native 19 | 20 | # oasis generated files 21 | setup.data 22 | setup.log 23 | 24 | # savegame 25 | FLATHEAD.SAV 26 | 27 | # mirage-specific 28 | Makefile 29 | .mirage.config 30 | *.hvt 31 | *.spt 32 | *.virtio 33 | *.muen 34 | *.genode 35 | *.xen 36 | key_gen.ml 37 | main.ml 38 | *.opam 39 | myocamlbuild.ml 40 | static*.ml 41 | static*.mli 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # flathead 2 | 3 | This is a fork of Eric Lippert's Z-machine interpreter, "flathead". See also his blog series at [ericlippert.com](https://ericlippert.com/category/zmachine/). 4 | 5 | This branch (`mirage`) is a port of flathead to run as a MirageOS unikernel. 6 | 7 | There are also some other branches of interest in this repository: 8 | 9 | - [`update-working`](https://github.com/mato/flathead/tree/update-working): An update of Eric's working code to use ocamlbuild, should work on any OCaml system with the Graphics package available. 10 | - [`tty`](https://github.com/mato/flathead/tree/tty): A simplistic replacement of the Graphics code to use a terminal, should work on any UNIX-based OCaml system. 11 | 12 | -------------------------------------------------------------------------------- /lib/globals.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | let first_global = 16 5 | let last_global = 255 6 | 7 | let global_addr story (Global global) = 8 | if global < first_global || global > last_global then 9 | failwith "global variable index out of range" 10 | else 11 | let (Global_table_base base) = Story.global_variables_table_base story in 12 | let base = Word_address base in 13 | let offset = global - first_global in 14 | inc_word_addr_by base offset 15 | 16 | let read story global = 17 | Story.read_word story (global_addr story global) 18 | 19 | let write story global value = 20 | Story.write_word story (global_addr story global) value 21 | 22 | let display story = 23 | let to_string g = 24 | Printf.sprintf "%02x %04x\n" (g - first_global) (read story (Global g)) in 25 | accumulate_strings_loop to_string first_global (last_global + 1) 26 | 27 | -------------------------------------------------------------------------------- /lib/randomness.ml: -------------------------------------------------------------------------------- 1 | (* See wikipedia article on xorshift *) 2 | 3 | type t = 4 | { 5 | w : Int32.t; 6 | x : Int32.t; 7 | y : Int32.t; 8 | z : Int32.t 9 | } 10 | 11 | (* Produces a non-negative random integer between 1 and n, 12 | and steps the generator. *) 13 | let next r n = 14 | let xor = Int32.logxor in 15 | let sl = Int32.shift_left in 16 | let sr = Int32.shift_right_logical in 17 | let rem = Int32.rem in 18 | let to_int = Int32.to_int in 19 | let of_int = Int32.of_int in 20 | let t = xor r.x (sl r.x 11) in 21 | let x = r.y in 22 | let y = r.z in 23 | let z = r.w in 24 | let w = xor (xor (xor r.w (sr r.w 19)) t) (sr t 8) in 25 | let r = 1 + ((to_int (rem w (of_int n)) + n) mod n) in 26 | (r, { w; x; y; z }) 27 | 28 | let make_seeded seed = 29 | let of_int = Int32.of_int in 30 | { w = of_int seed; x = of_int 123; y = of_int 123; z = of_int 123 } 31 | 32 | let make_random () = 33 | Random.self_init(); 34 | let seed = Random.int 1000000 in 35 | make_seeded seed 36 | -------------------------------------------------------------------------------- /lib/immutable_bytes.ml: -------------------------------------------------------------------------------- 1 | open Type 2 | open Utility 3 | 4 | module IntMap = Map.Make(struct type t = int let compare = compare end) 5 | 6 | type t = 7 | { 8 | original_bytes : string; 9 | edits : char IntMap.t 10 | } 11 | 12 | let make bytes = 13 | { original_bytes = bytes; edits = IntMap.empty } 14 | 15 | let size bytes = 16 | String.length bytes.original_bytes 17 | 18 | let read_byte bytes address = 19 | if is_out_of_range address (size bytes) then 20 | failwith "address is out of range" 21 | else 22 | let (Byte_address addr) = address in 23 | let c = 24 | if IntMap.mem addr bytes.edits then IntMap.find addr bytes.edits 25 | else bytes.original_bytes.[addr] in 26 | int_of_char c 27 | 28 | let write_byte bytes address value = 29 | if is_out_of_range address (size bytes) then 30 | failwith "address is out of range" 31 | else 32 | let (Byte_address addr) = address in 33 | let b = char_of_int (byte_of_int value) in 34 | { bytes with edits = IntMap.add addr b bytes.edits } 35 | 36 | let original bytes = 37 | { bytes with edits = IntMap.empty } 38 | -------------------------------------------------------------------------------- /lib/evaluation_stack.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Iff 3 | 4 | type t = 5 | { 6 | items : int list 7 | } 8 | 9 | let empty = { items = [] } 10 | 11 | let length stack = 12 | List.length stack.items 13 | 14 | let peek stack = 15 | match stack.items with 16 | | [] -> failwith "peeking an empty stack" 17 | | h :: _ -> h 18 | 19 | let pop stack = 20 | match stack.items with 21 | | [] -> failwith "popping empty stack" 22 | | _ :: t -> { items = t } 23 | 24 | let push stack item = 25 | let item = unsigned_word item in 26 | { items = item :: stack.items } 27 | 28 | let display_stack stack = 29 | let to_string item = 30 | Printf.sprintf " %04x" item in 31 | let folder acc item = 32 | acc ^ (to_string item) in 33 | let items = stack.items in 34 | List.fold_left folder "" items 35 | 36 | let make_stack_records stack = 37 | let rec aux acc items = 38 | match items with 39 | | [] -> acc 40 | | h :: t -> aux ((Integer16 (Some (h))) :: acc) t in 41 | List.rev (aux [] stack.items) 42 | 43 | let make_stack_from_record records = 44 | let decode_int16 form = 45 | match form with 46 | | (Integer16 (Some v)) -> v 47 | | _ -> failwith "TODO handle failure reading evaluation stack" in 48 | { items = List.rev (List.map decode_int16 records) } 49 | -------------------------------------------------------------------------------- /lib/routine.ml: -------------------------------------------------------------------------------- 1 | open Type 2 | open Utility 3 | 4 | let maximum_local = 15 5 | 6 | let locals_count story (Routine routine_address) = 7 | let count = Story.read_byte story (Byte_address routine_address) in 8 | if count > maximum_local then failwith "routine must have fewer than 16 locals" 9 | else count 10 | 11 | let first_instruction story (Routine routine_address) = 12 | (* Spec: 13 | * A routine begins with one byte indicating the number of local 14 | variables it has (between 0 and 15 inclusive). 15 | * In Versions 1 to 4, that number of 2-byte words follows, giving initial 16 | values for these local variables. 17 | * In Versions 5 and later, the initial values are all zero. 18 | * Execution of instructions begins from the byte after this header 19 | information *) 20 | if Story.v4_or_lower (Story.version story) then 21 | let count = locals_count story (Routine routine_address) in 22 | Instruction (routine_address + 1 + count * 2) 23 | else 24 | Instruction (routine_address + 1) 25 | 26 | (* Note that here the locals are indexed from 1 to 15, not 0 to 14 *) 27 | let local_default_value story (Routine routine_address) n = 28 | if n < 1 || n > maximum_local then 29 | failwith "invalid local" 30 | else if Story.v4_or_lower (Story.version story) then 31 | Story.read_word story (Word_address (routine_address + 1 + 2 * (n - 1))) 32 | else 33 | 0 34 | -------------------------------------------------------------------------------- /lib/status_line.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | let empty = Status None 5 | 6 | let make story = 7 | let current_object_global = Global 16 in 8 | let current_score_global = Global 17 in (* also hours *) 9 | let turn_count_global = Global 18 in (* also minutes *) 10 | 11 | let current_object () = 12 | Object (Globals.read story current_object_global) in 13 | let current_object_name () = 14 | let c = current_object () in 15 | if c = Object.invalid_object then "" 16 | else Object.name story c in 17 | let status_globals () = 18 | let score = signed_word (Globals.read story current_score_global) in 19 | let turn = Globals.read story turn_count_global in 20 | (score, turn) in 21 | let build_status_line right = 22 | let right_length = String.length right in 23 | let left = current_object_name () in 24 | let left_length = String.length left in 25 | let (Character_width width) = Story.screen_width story in 26 | let left_trimmed = 27 | if left_length + right_length < width then left 28 | else left_string left (width - right_length - 1) in (* TODO: Assumes that width >= right_length *) 29 | let space_count = width - right_length - (String.length left_trimmed) in 30 | left_trimmed ^ (spaces space_count) ^ right in 31 | let time_status () = 32 | let (hours, minutes) = status_globals () in 33 | let suffix = if hours >= 12 then "PM" else "AM" in 34 | let adjusted_hours = (hours mod 12) + 12 in 35 | let text = Printf.sprintf "%d:%02d%s" adjusted_hours minutes suffix in 36 | build_status_line text in 37 | let score_status () = 38 | let (score, turns) = status_globals () in 39 | let text = Printf.sprintf "%d/%d" score turns in 40 | build_status_line text in 41 | match Story.status_line_kind story with 42 | | NoStatus -> empty 43 | | TimeStatus -> Status (Some (time_status ()) ) 44 | | ScoreStatus -> Status (Some (score_status ()) ) 45 | -------------------------------------------------------------------------------- /lib/transcript.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | 3 | type t = 4 | { 5 | lines : string list; 6 | width : int 7 | } 8 | 9 | let empty = { lines = []; width = 80 } 10 | 11 | (* Word-wraps the last line in a list of lines. Assumes that 12 | the tail of the list is already word-wrapped. Returns the 13 | new list. *) 14 | 15 | let rec wrap_lines lines line_length = 16 | match lines with 17 | | [] -> [] 18 | | unwrapped_line :: wrapped_lines -> 19 | if String.contains unwrapped_line '\n' then 20 | (* Recursive case 1: there is a return in the last string. 21 | Split the string, solve the wrapping problem with no return, 22 | and then recurse on the remainder of the string. *) 23 | let (left, right) = break_string unwrapped_line '\n' in 24 | let w1 = wrap_lines (left :: wrapped_lines) line_length in 25 | wrap_lines (right :: w1) line_length 26 | else 27 | let len = String.length unwrapped_line in 28 | if len > line_length then 29 | (* Recursive case 2: there are no returns but the line is too long. 30 | Try to find a space to break on, break it, and recurse. *) 31 | let space_location = reverse_index_from unwrapped_line ' ' line_length in 32 | let break_point = 33 | match space_location with 34 | | None -> line_length 35 | | Some location -> location in 36 | let right = right_string unwrapped_line (break_point + 1) in 37 | let left = left_string unwrapped_line break_point in 38 | (* The left portion is short enough but the right might not be. *) 39 | wrap_lines (right :: left :: wrapped_lines) line_length 40 | else 41 | (* Base case: the line has no breaks and is short enough. Do nothing. *) 42 | lines 43 | 44 | let append transcript text = 45 | let unwrapped_lines = 46 | match transcript.lines with 47 | | [] -> [text] 48 | | h :: t -> (h ^ text) :: t in 49 | let wrapped_lines = wrap_lines unwrapped_lines transcript.width in 50 | { transcript with lines = wrapped_lines } 51 | -------------------------------------------------------------------------------- /lib_telnet/wire.ml: -------------------------------------------------------------------------------- 1 | 2 | [%%cenum 3 | type telnet_command = 4 | | SUBNEG_END [@id 240] (* SE *) 5 | | NOP [@id 241] 6 | | DATA_MARK [@id 242] (* The data stream portion of a Synch. This should always be accompanied by a TCP Urgent notification. *) 7 | | BREAK [@id 243] (* BRK *) 8 | | INTERRUPT_PROCESS [@id 244] 9 | | ABORT_OUTPUT [@id 245] 10 | | ARE_YOU_THERE [@id 246] 11 | | ERASE_CHARACTER [@id 247] 12 | | ERASE_LINE [@id 248] 13 | | GO_AHEAD [@id 249] 14 | | SUBNEG [@id 250] 15 | | WILL [@id 251] (* option code *) 16 | | WILL_NOT [@id 252] (* option code *) 17 | | DO [@id 253] (* option code *) 18 | | DO_NOT [@id 254] 19 | | IAC [@id 255] (* Data Byte 255. *) 20 | [@@uint8_t] 21 | ] 22 | 23 | [%%cenum 24 | type telnet_option = 25 | | Binary_Transmission 26 | | Echo 27 | | Reconnection 28 | | Suppress_Go_Ahead 29 | | Approx_Message_Size_Negotiation 30 | | Status 31 | | Timing_Mark 32 | | Remote_Controlled_Trans_and_Echo 33 | | Output_Line_Width 34 | | Output_Page_Size 35 | | Output_Carriage_Return_Disposition 36 | | Output_Horizontal_Tab_Stops 37 | | Output_Horizontal_Tab_Disposition 38 | | Output_Formfeed_Disposition 39 | | Output_Vertical_Tabstops 40 | | Output_Vertical_Tab_Disposition 41 | | Output_Linefeed_Disposition 42 | | Extended_ASCII 43 | | Logout 44 | | Byte_Macro 45 | | Data_Entry_Terminal 46 | | SUPDUP 47 | | SUPDUP_Output 48 | | Send_Location 49 | | Terminal_Type 50 | | End_of_Record 51 | | TACACS_User_Identification 52 | | Output_Marking 53 | | Terminal_Location_Number 54 | | Telnet_3270_Regime 55 | | X_3_PAD 56 | | Negotiate_About_Window_Size 57 | | Terminal_Speed 58 | | Remote_Flow_Control 59 | | Linemode 60 | | X_Display_Location 61 | | Environment_Option 62 | | Authentication_Option 63 | | Encryption_Option 64 | | New_Environment_Option 65 | | TN3270E 66 | | XAUTH 67 | | CHARSET 68 | | Telnet_Remote_Serial_Port 69 | | Com_Port_Control_Option 70 | | Telnet_Suppress_Local_Echo 71 | | Telnet_Start_TLS 72 | | KERMIT 73 | | SEND_URL 74 | | FORWARD_X 75 | (* 50-137,Unassigned *) 76 | | TELOPT_PRAGMA_LOGON [@id 138] 77 | | TELOPT_SSPI_LOGON 78 | | TELOPT_PRAGMA_HEARTBEAT 79 | (* 141-254 *) 80 | | Extended_Options_List [@id 255] 81 | [@@uint8_t] 82 | ] 83 | -------------------------------------------------------------------------------- /lib/frameset.ml: -------------------------------------------------------------------------------- 1 | (* The frame set is the stack of activation frames; each activation frame 2 | has a local variable storage, evaluation stack, and information about 3 | the call site that created this activation. *) 4 | 5 | type t = 6 | { 7 | initial_frame : Frame.t; 8 | frames : Frame.t list 9 | } 10 | 11 | let make initial_frame = 12 | { initial_frame ; frames = []} 13 | 14 | let current_frame frameset = 15 | match frameset.frames with 16 | | [] -> frameset.initial_frame 17 | | h :: _ -> h 18 | 19 | let set_current_frame frameset frame = 20 | match frameset.frames with 21 | | [] -> { frameset with initial_frame = frame } 22 | | _ :: t -> { frameset with frames = frame :: t } 23 | 24 | let add_frame frameset frame = 25 | { frameset with frames = frame :: frameset.frames } 26 | 27 | let remove_frame frameset = 28 | match frameset.frames with 29 | | [] -> failwith "Attempting to remove initial frame" 30 | | _ :: t -> { frameset with frames = t } 31 | 32 | let peek_stack frameset = 33 | Frame.peek_stack (current_frame frameset) 34 | 35 | let pop_stack frameset = 36 | set_current_frame frameset (Frame.pop_stack (current_frame frameset)) 37 | 38 | let push_stack frameset value = 39 | set_current_frame frameset (Frame.push_stack (current_frame frameset) value) 40 | 41 | let read_local frameset local = 42 | Frame.read_local (current_frame frameset) local 43 | 44 | let write_local frameset local value = 45 | set_current_frame frameset (Frame.write_local (current_frame frameset) local value) 46 | 47 | let display_frames frameset = 48 | let folder acc f =acc ^ (Frame.display_frame f) in 49 | (List.fold_left folder "" frameset.frames) ^ (Frame.display_frame frameset.initial_frame) 50 | 51 | let make_frameset_record frameset = 52 | let head = Frame.make_frame_record frameset.initial_frame in 53 | let tail = List.rev (List.map Frame.make_frame_record frameset.frames) in 54 | List.rev (head :: tail) 55 | 56 | let make_frameset_from_records frame_records = 57 | (* TODO: Handle the error case where there is no initial record. *) 58 | let oldest_first = List.rev frame_records in 59 | let initial_frame = Frame.make_frame_from_record (List.hd oldest_first) in 60 | let newest_first = List.rev (List.tl oldest_first) in 61 | let frames = List.map Frame.make_frame_from_record newest_first in 62 | { initial_frame; frames } 63 | -------------------------------------------------------------------------------- /lib/runner.ml: -------------------------------------------------------------------------------- 1 | open Type 2 | 3 | type t = 4 | { 5 | interpreter : Interpreter.t; 6 | } 7 | 8 | let make interpreter = { 9 | interpreter = interpreter; 10 | } 11 | 12 | let clear_screen () = 13 | print_string "\027[2J" 14 | 15 | let cursor_home () = 16 | print_string "\027[H" 17 | 18 | let draw_screen screen = 19 | cursor_home (); 20 | (* draw_status screen; *) 21 | let rec aux n = 22 | let (Character_height h) = Screen.height screen in 23 | if n < h then ( 24 | let text = Screen.get_line_at screen (Character_y (n + 1)) in 25 | print_string text; 26 | aux (n + 1)) in 27 | aux 0 ; 28 | flush stdout 29 | 30 | let needs_more runner = 31 | let screen = Interpreter.screen runner.interpreter in 32 | Screen.needs_more screen 33 | 34 | let draw_interpreter runner = 35 | let interpreter = runner.interpreter in 36 | let screen = Interpreter.screen interpreter in 37 | let state = Interpreter.state interpreter in 38 | let input = Interpreter.input interpreter in 39 | let has_new_output = Interpreter.has_new_output interpreter in 40 | if state = Interpreter.Waiting_for_input then 41 | draw_screen (Screen.fully_scroll (Screen.print screen input)) 42 | else if has_new_output then 43 | let screen_to_draw = 44 | if needs_more runner then 45 | Screen.more screen 46 | else 47 | screen in 48 | draw_screen screen_to_draw 49 | 50 | let get_char () = 51 | let termio = Unix.tcgetattr Unix.stdin in 52 | let () = 53 | Unix.tcsetattr Unix.stdin Unix.TCSADRAIN 54 | { termio with Unix.c_icanon = false; Unix.c_echo = false } in 55 | let res = input_char stdin in 56 | Unix.tcsetattr Unix.stdin Unix.TCSADRAIN termio; 57 | res 58 | 59 | let do_step runner = 60 | let interpreter = runner.interpreter in 61 | let state = Interpreter.state interpreter in 62 | let new_interpreter = match state with 63 | | Interpreter.Waiting_for_input -> 64 | Interpreter.step_with_input interpreter (get_char ()) 65 | | Interpreter.Halted -> 66 | failwith "Halted" 67 | | Interpreter.Running -> 68 | Interpreter.step interpreter 69 | in 70 | { interpreter = new_interpreter } 71 | 72 | let rec main_loop runner = 73 | let r = do_step runner in 74 | draw_interpreter r; 75 | main_loop r 76 | 77 | let run runner = 78 | clear_screen (); 79 | main_loop runner 80 | -------------------------------------------------------------------------------- /lib/compression.ml: -------------------------------------------------------------------------------- 1 | open Type 2 | open Utility 3 | 4 | let compress story = 5 | let original_story = Story.original story in 6 | let (Static_memory_base memory_length) = Story.static_memory_base story in 7 | let rec aux acc i c = 8 | if i = memory_length then 9 | acc 10 | else if c = 256 then 11 | let encoded = "\000" ^ (string_of_byte (c - 1)) in 12 | aux (acc ^ encoded) i 0 13 | else 14 | let original_byte = Story.read_byte original_story (Byte_address i) in 15 | let current_byte = Story.read_byte story (Byte_address i) in 16 | let combined = original_byte lxor current_byte in 17 | if combined = 0 then 18 | aux acc (i + 1) (c + 1) 19 | else if c > 0 then 20 | let encoded = "\000" ^ (string_of_byte (c - 1)) ^ (string_of_byte combined) in 21 | aux (acc ^ encoded) (i + 1) 0 22 | else 23 | let encoded = string_of_byte combined in 24 | aux (acc ^ encoded) (i + 1) 0 in 25 | Compressed (aux "" 0 0) 26 | 27 | let apply_uncompressed_changes story (Uncompressed uncompressed) = 28 | (* We cannot simply say "make a new dynamic memory chunk out of 29 | these bytes" because then the *next* time we load a save game, 30 | that dynamic memory will be the "original" memory, which is wrong. 31 | We need to maintain the truly original loaded-off-disk memory. *) 32 | let original_story = Story.original story in 33 | let length = String.length uncompressed in 34 | let rec aux index acc = 35 | if index >= length then 36 | acc 37 | else 38 | let new_byte = int_of_char uncompressed.[index] in 39 | let orig_byte = Story.read_byte original_story (Byte_address index) in 40 | let new_story = 41 | if new_byte = orig_byte then acc 42 | else Story.write_byte acc (Byte_address index) new_byte in 43 | aux (index + 1) new_story in 44 | aux 0 original_story 45 | 46 | let apply_compressed_changes story (Compressed compressed) = 47 | let original_story = Story.original story in 48 | let length = String.length compressed in 49 | let rec aux index_change index_mem acc = 50 | if index_change >= length then 51 | acc 52 | else 53 | let b = int_of_char compressed.[index_change] in 54 | if b = 0 then 55 | (* TODO: If length - 1 this is a problem *) 56 | let c = 1 + int_of_char compressed.[index_change + 1] in 57 | aux (index_change + 2) (index_mem + c) acc 58 | else 59 | let orig_byte = Story.read_byte original_story (Byte_address index_mem) in 60 | let new_byte = b lxor orig_byte in 61 | let new_story = Story.write_byte acc (Byte_address index_mem) new_byte in 62 | aux (index_change + 1) (index_mem + 1) new_story in 63 | aux 0 0 original_story 64 | -------------------------------------------------------------------------------- /lib/local_store.ml: -------------------------------------------------------------------------------- 1 | (* The local variables store knows 2 | * Which locals were supplied from arguments 3 | * How many locals there are 4 | * Values of all locals *) 5 | 6 | open Utility 7 | open Iff 8 | open Type 9 | 10 | type t = 11 | { 12 | locals : int IntMap.t; 13 | count : int; 14 | arguments_supplied : int; 15 | } 16 | 17 | (* TODO: Be more clever *) 18 | let make locals count arguments_supplied = 19 | { locals; count; arguments_supplied } 20 | 21 | let empty = 22 | { locals = IntMap.empty; count = 0; arguments_supplied = 0 } 23 | 24 | let maximum_local = 15 25 | 26 | let write_local local_store (Local local) value = 27 | if local < 0 || local > local_store.count then 28 | failwith (Printf.sprintf "write_local: local %d invalid; count is %d" local local_store.count) 29 | else 30 | let value = unsigned_word value in 31 | { local_store with locals = IntMap.add local value local_store.locals } 32 | 33 | let read_local local_store (Local local) = 34 | if local < 0 || local > local_store.count then 35 | failwith (Printf.sprintf "read_local: local %d invalid; count is %d" local local_store.count) 36 | else 37 | IntMap.find local local_store.locals 38 | 39 | (* Handy debugging methods *) 40 | let display_locals local_store = 41 | let to_string local value = 42 | Printf.sprintf "local%01x=%04x " (local - 1) value in 43 | let folder local value acc = 44 | acc ^ (to_string local value) in 45 | let locals = local_store.locals in 46 | IntMap.fold folder locals "" 47 | 48 | let make_locals_record local_store = 49 | let rec aux acc n = 50 | if n = 0 then 51 | acc 52 | else 53 | let local_value = read_local local_store (Local n) in 54 | aux ((Integer16 (Some local_value)) :: acc) (n - 1) in 55 | aux [] local_store.count 56 | 57 | let make_locals_from_record arguments_supplied locals_list = 58 | let decode_int16 form = 59 | match form with 60 | | (Integer16 (Some v)) -> v 61 | | _ -> failwith "TODO handle failure reading locals" in 62 | let rec aux map i locs = 63 | match locs with 64 | | [] -> map 65 | | h :: t -> 66 | let v = decode_int16 h in 67 | let new_map = IntMap.add i v map in 68 | aux new_map (i + 1) t in 69 | let map = aux IntMap.empty 1 locals_list in 70 | { locals = map; count = List.length locals_list ; arguments_supplied } 71 | 72 | let add local_store (Local n) default_value = 73 | let locals = IntMap.add n default_value local_store.locals in 74 | let count = max local_store.count n in 75 | { local_store with locals; count } 76 | 77 | let create_default_locals story routine_address = 78 | let count = Routine.locals_count story routine_address in 79 | let rec aux acc i= 80 | if i > count then 81 | acc 82 | else 83 | let default_value = Routine.local_default_value story routine_address i in 84 | let new_store = add acc (Local i) default_value in 85 | aux new_store (i + 1) in 86 | aux empty 1 87 | 88 | let write_arguments local_store arguments = 89 | let rec aux acc args i = 90 | match args with 91 | | [] -> acc 92 | | arg :: tail -> 93 | if i > acc.count then 94 | acc 95 | else 96 | let new_store = write_local acc (Local i) arg in 97 | aux new_store tail (i + 1) in 98 | aux local_store arguments 1 99 | -------------------------------------------------------------------------------- /lib/reachability.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | (* Any given instruction in a routine either goes on to the next instruction, 5 | when it is done, or branches to another instruction when it is done, or terminates 6 | the routine. Given the address of an instruction, what are all the reachable instructions 7 | in this routine? Note that this could miss instructions if a jump is made to a location 8 | read from a variable. *) 9 | 10 | let following_instruction instr = 11 | if Instruction.continues_to_following (Instruction.opcode instr) then 12 | let (Instruction addr) = (Instruction.address instr) in 13 | let length = (Instruction.length instr) in 14 | [Instruction (addr + length)] 15 | else 16 | [] 17 | 18 | let branch_target_instruction instr = 19 | match Instruction.branch instr with 20 | | None 21 | | Some (_, Return_false) 22 | | Some (_, Return_true) -> [] 23 | | Some (_, Branch_address address) -> [address] 24 | 25 | let jump_target_instruction instr = 26 | match (Instruction.opcode instr, Instruction.operands instr) with 27 | | (OP1_140, [Large offset]) -> 28 | let offset = signed_word offset in 29 | [ Instruction.jump_address instr offset ] 30 | | _ -> [] 31 | 32 | let all_reachable_addresses_in_routine story instr_address = 33 | let immediately_reachable_addresses address = 34 | let instr = Instruction.decode story address in 35 | let following = following_instruction instr in 36 | let branch = branch_target_instruction instr in 37 | let jump = jump_target_instruction instr in 38 | following @ branch @ jump in 39 | reflexive_closure instr_address immediately_reachable_addresses 40 | 41 | let display_reachable_instructions story address = 42 | let reachable = all_reachable_addresses_in_routine story address in 43 | let sorted = List.sort compare reachable in 44 | let to_string addr = 45 | let instr = Instruction.decode story addr in 46 | Instruction.display instr story in 47 | accumulate_strings to_string sorted 48 | 49 | let display_routine story routine_address = 50 | let first = Routine.first_instruction story routine_address in 51 | display_reachable_instructions story first 52 | 53 | (* Takes the address of the first instruction in a routine, produces 54 | a list of addresses of all routines called in the routine. *) 55 | (* Again, this can miss routines that are called with a variable as the address. *) 56 | let reachable_routines_in_routine story instr_address = 57 | let reachable_instrs = all_reachable_addresses_in_routine story instr_address in 58 | let option_fold routines instr_addr = 59 | let instr = Instruction.decode story instr_addr in 60 | match Instruction.call_address instr story with 61 | | None -> routines 62 | | Some routine_address -> routine_address :: routines in 63 | List.fold_left option_fold [] reachable_instrs 64 | 65 | let all_routines story = 66 | let ipc = Story.initial_program_counter story in 67 | let called_by_main = reachable_routines_in_routine story ipc in 68 | let relation routine = 69 | reachable_routines_in_routine story (Routine.first_instruction story routine) in 70 | let all_routines = reflexive_closure_many called_by_main relation in 71 | List.sort compare all_routines 72 | 73 | let display_all_routines story = 74 | let routines = all_routines story in 75 | let to_string r = 76 | (display_routine story r) ^ "\n\n" in 77 | accumulate_strings to_string routines 78 | -------------------------------------------------------------------------------- /lib/dictionary.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | let invalid_address = Dictionary_address 0 5 | 6 | (* The table is laid out as follows. First there is a header: 7 | 8 | byte giving the number of word separators 9 | the word separators, one byte each 10 | byte giving the number of bytes in each dictionary entry 11 | word giving the number of table entries which follow 12 | 13 | Each entry is either 4 (in V1-3) or 6 (otherwise) bytes of zstring data, 14 | followed by enough bytes to make up the size of the dictionary entry. *) 15 | 16 | let max_word_length story = 17 | if Story.v3_or_lower (Story.version story) then 6 else 9 18 | 19 | let word_separators_base (Dictionary_base base) = 20 | Byte_address base 21 | 22 | let word_separator_address base (Word_separator_number n) = 23 | let ws_base = word_separators_base base in 24 | inc_byte_addr_by ws_base (n + 1) 25 | 26 | let word_separators_count story = 27 | let dict_base = Story.dictionary_base story in 28 | let ws_base = word_separators_base dict_base in 29 | Story.read_byte story ws_base 30 | 31 | let word_separators story = 32 | let dict_base = Story.dictionary_base story in 33 | let count = word_separators_count story in 34 | let rec aux acc i = 35 | if i = count then 36 | acc 37 | else 38 | let addr = word_separator_address dict_base (Word_separator_number i) in 39 | let separator = string_of_char (char_of_int (Story.read_byte story addr)) in 40 | aux (separator :: acc) (i + 1) in 41 | aux [] 0 42 | 43 | let entry_base story = 44 | let dict_base = Story.dictionary_base story in 45 | let ws_count = word_separators_count story in 46 | let ws_base = word_separators_base dict_base in 47 | inc_byte_addr_by ws_base (ws_count + 1) 48 | 49 | let entry_length story = 50 | Story.read_byte story (entry_base story) 51 | 52 | let entry_count story = 53 | let (Byte_address addr) = inc_byte_addr (entry_base story) in 54 | Story.read_word story (Word_address addr) 55 | 56 | (* This is the address of the actual dictionary entries, past the initial 57 | header with the word separators. *) 58 | let table_base story = 59 | let (Byte_address addr) = inc_byte_addr_by (entry_base story) 3 in 60 | Dictionary_table_base addr 61 | 62 | let entry_address story (Dictionary dictionary_number) = 63 | let (Dictionary_table_base base) = table_base story in 64 | let length = entry_length story in 65 | Dictionary_address (base + dictionary_number * length) 66 | 67 | let entry story dictionary_number = 68 | let (Dictionary_address addr) = entry_address story dictionary_number in 69 | Zstring.read story (Zstring addr) 70 | 71 | (* Takes a string and finds the address of the corresponding zstring 72 | in the dictionary *) 73 | (* Note this computes the address of the dictionary string, not the dictionary 74 | entry number. *) 75 | 76 | (* This returns zero if the string cannot be found. Of course zero is a valid 77 | address in the Z-machine; it's the location of the version number. But it 78 | is conventionally used here as an invalid address. *) 79 | let lookup story text = 80 | let count = entry_count story in 81 | let truncated = truncate text (max_word_length story) in 82 | let compare i = 83 | String.compare (entry story (Dictionary i)) truncated in 84 | match binary_search 0 count compare with 85 | | None -> invalid_address 86 | | Some entry_index -> entry_address story (Dictionary entry_index) 87 | 88 | let display_dictionary story = 89 | let count = entry_count story in 90 | let header = 91 | (Printf.sprintf "Separator count: %d\n" (word_separators_count story)) ^ 92 | (Printf.sprintf "Entry length: %d\n" (entry_length story)) ^ 93 | (Printf.sprintf "Entry count: %d\n" count) in 94 | let to_string i = 95 | Printf.sprintf "%04x: %s\n" i (entry story (Dictionary i)) in 96 | header ^ (accumulate_strings_loop to_string 0 count) 97 | -------------------------------------------------------------------------------- /lib/quetzal.ml: -------------------------------------------------------------------------------- 1 | open Iff 2 | open Type 3 | 4 | let ifzs_ifhd = 5 | Record [ 6 | Header "IFhd"; 7 | Length None; 8 | Integer16 None; (* release number *) 9 | ByteString (None, 6); (* serial number *) 10 | Integer16 None; (* checksum *) 11 | Integer24 None] (* program counter *) 12 | 13 | let ifzs_frame = 14 | Record [ 15 | Integer24 None; (* return address *) 16 | BitField [ 17 | Assign ("v", Integer4 None); (* count of local variables *) 18 | Bit (4, None)]; (* caller discards result *) 19 | Integer8 None; (* variable caller will store result in *) 20 | BitField [ 21 | Bit (0, None); (* argument 0 was supplied *) 22 | Bit (1, None); (* argument 1 was supplied *) 23 | Bit (2, None); (* argument 2 was supplied *) 24 | Bit (3, None); (* argument 3 was supplied *) 25 | Bit (4, None); (* argument 4 was supplied *) 26 | Bit (5, None); (* argument 5 was supplied *) 27 | Bit (6, None)]; (* argument 6 was supplied *) 28 | Assign ("n", Integer16 None); (* size of evaluation stack in words *) 29 | SizedList (Lookup "v", [Integer16 None]); (* local variables *) 30 | SizedList (Lookup "n", [Integer16 None])] (* evaluation stack *) 31 | 32 | let ifzs_stacks = 33 | Record [ 34 | Header "Stks"; 35 | Length None; 36 | UnsizedList [ifzs_frame]] 37 | 38 | let ifzs_cmem = 39 | Record [ 40 | Header "CMem"; 41 | Length None; 42 | RemainingBytes None] 43 | 44 | let ifzs_umem = 45 | Record [ 46 | Header "UMem"; 47 | Length None; 48 | RemainingBytes None] 49 | 50 | let ifzd_form = 51 | Record [ 52 | Header "FORM"; 53 | Length None; 54 | SubHeader "IFZS"; 55 | UnorderedList [ 56 | ifzs_ifhd; 57 | ifzs_stacks; 58 | ifzs_umem; 59 | ifzs_cmem]] 60 | 61 | let save 62 | (Release_number release) 63 | (Serial_number serial) 64 | (Checksum checksum) 65 | (Instruction pc) 66 | (Compressed compressed) frames = 67 | Record [ 68 | Header "FORM"; 69 | Length None; (* The writer will figure it out *) 70 | SubHeader "IFZS"; 71 | UnorderedList [ 72 | Record [ 73 | Header "IFhd"; 74 | Length None; 75 | Integer16 (Some release); 76 | ByteString (Some serial, 6); 77 | Integer16 (Some checksum); 78 | Integer24 (Some pc) ]; 79 | Record [ 80 | Header "CMem"; 81 | Length None; 82 | RemainingBytes (Some compressed)]; 83 | Record [ 84 | Header "Stks"; 85 | Length None; 86 | UnsizedList frames] ] ] 87 | 88 | let read_ifzd_chunks ifzd = 89 | match ifzd with 90 | | Record [ 91 | Header "FORM"; 92 | Length _; 93 | SubHeader "IFZS"; 94 | UnorderedList items] -> 95 | items 96 | | _ -> failwith "TODO: Handle failure reading ifzd" 97 | 98 | let read_header ifzd = 99 | let chunks = read_ifzd_chunks ifzd in 100 | let ifhd = find_record chunks "IFhd" in 101 | match ifhd with 102 | | Some Record [ 103 | Header "IFhd"; 104 | Length _; 105 | Integer16 Some release_number; 106 | ByteString (Some serial_number, 6); 107 | Integer16 Some checksum; 108 | Integer24 Some pc ] -> 109 | ((Release_number release_number), (Serial_number serial_number), (Checksum checksum), pc) 110 | | _ -> failwith "TODO handle failure reading ifhd" 111 | 112 | let read_stacks ifzd = 113 | let chunks = read_ifzd_chunks ifzd in 114 | let stacks_chunk = find_record chunks "Stks" in 115 | match stacks_chunk with 116 | | Some Record [ 117 | Header "Stks"; 118 | Length _; 119 | UnsizedList items ] -> items 120 | | _ -> failwith "TODO handle failure reading stacks" 121 | 122 | let read_memory ifzd = 123 | let chunks = read_ifzd_chunks ifzd in 124 | let cmem_chunk = find_record chunks "CMem" in 125 | let umem_chunk = find_record chunks "UMem" in 126 | let compressed = match cmem_chunk with 127 | | None -> None 128 | | Some Record [ 129 | Header "CMem"; 130 | Length Some length; 131 | RemainingBytes Some bytes] -> 132 | Some (Compressed bytes) 133 | | _ -> failwith "TODO: Handle failure reading CMem" in 134 | let uncompressed = match umem_chunk with 135 | | None -> None 136 | | Some Record [ 137 | Header "UMem"; 138 | Length Some length; 139 | RemainingBytes Some bytes] -> 140 | Some (Uncompressed bytes) 141 | | _ -> failwith "TODO: Handle failure reading UMem" in 142 | (compressed, uncompressed) 143 | -------------------------------------------------------------------------------- /lib/deque.ml: -------------------------------------------------------------------------------- 1 | (* Simplified version of Chris Okasaki's deque. *) 2 | type 'a t = 3 | { 4 | front : 'a list; 5 | front_length : int; 6 | back : 'a list; 7 | back_length : int 8 | } 9 | 10 | (* Invariants: front_length and back_length are the lengths of the lists *) 11 | (* Invariants: front_length <= c * back_length + 1 *) 12 | (* Invariants: back_length <= c * front_length + 1 *) 13 | 14 | exception Empty 15 | exception InvalidIndex 16 | 17 | let empty = 18 | { 19 | front = []; 20 | front_length = 0; 21 | back = []; 22 | back_length = 0 23 | } 24 | 25 | let is_empty deque = 26 | deque.front_length + deque.back_length = 0 27 | 28 | let length deque = 29 | deque.front_length + deque.back_length 30 | 31 | (* TODO: balance is not part of the public surface of the module; 32 | consider creating a module interface file. *) 33 | let balance deque = 34 | let c = 3 in 35 | let take items n = 36 | let rec aux items n acc = 37 | match (items, n) with 38 | | (_, 0) -> acc 39 | | ([], _) -> acc 40 | | ((h :: t), _) -> aux t (n - 1) (h :: acc) in 41 | List.rev (aux items n []) in 42 | let rec drop items n = 43 | match(items, n) with 44 | | (_, 0) -> items 45 | | ([], _) -> [] 46 | | (h :: t, _) -> drop t (n - 1) in 47 | if deque.front_length > c * deque.back_length + 1 then 48 | let new_front_length = (deque.front_length + deque.back_length) / 2 in 49 | let new_back_length = deque.front_length + deque.back_length - new_front_length in 50 | { 51 | front = take deque.front new_front_length; 52 | front_length = new_front_length; 53 | back = deque.back @ (List.rev (drop deque.front new_front_length)); 54 | back_length = new_back_length 55 | } 56 | else if deque.back_length > c * deque.front_length + 1 then 57 | let new_front_length = (deque.front_length + deque.back_length) / 2 in 58 | let new_back_length = deque.front_length + deque.back_length - new_front_length in 59 | { 60 | front = deque.front @ List.rev(drop deque.back new_back_length); 61 | front_length = new_front_length; 62 | back = take deque.back new_back_length; 63 | back_length = new_back_length 64 | } 65 | else deque 66 | 67 | let enqueue_front deque item = 68 | balance { deque with 69 | front = item :: deque.front; 70 | front_length = deque.front_length + 1} 71 | 72 | let enqueue_back deque item = 73 | balance { deque with 74 | back = item :: deque.back; 75 | back_length = deque.back_length + 1} 76 | 77 | let peek_front deque = 78 | match deque with 79 | | { front = []; back = [] } -> raise Empty 80 | | { front = h :: _} -> h 81 | | { back = [h] } -> h 82 | | _ -> failwith "peek_front: Front is empty, back has more than one item" 83 | 84 | let peek_back deque = 85 | match deque with 86 | | { front = []; back = [] } -> raise Empty 87 | | { back = h :: _} -> h 88 | | { front = [h] } -> h 89 | | _ -> failwith "peek_back: Back is empty, front has more than one item" 90 | 91 | let dequeue_front deque = 92 | match deque with 93 | | { front = []; back = [] } -> raise Empty 94 | | { front = [_]; back = [] } -> empty 95 | | { front = []; back = [_] } -> empty 96 | | { front = _ :: t } -> 97 | balance { deque with front = t; front_length = deque.front_length - 1 } 98 | | _ -> failwith "dequeue_front: Front is empty, back has more than one item" 99 | 100 | let dequeue_back deque = 101 | match deque with 102 | | { front = []; back = [] } -> raise Empty 103 | | { front = [_]; back = [] } -> empty 104 | | { front = []; back = [_] } -> empty 105 | | { back = _ :: t } -> 106 | balance { deque with back = t; back_length = deque.back_length - 1 } 107 | | _ -> failwith "dequeue_back: Back is empty, front has more than one item" 108 | 109 | let peek_front_at deque n = 110 | let length = deque.front_length + deque.back_length in 111 | if (n < 0) || (n >= length) then raise InvalidIndex 112 | else if n < deque.front_length then List.nth deque.front n 113 | else List.nth deque.back (length - 1 - n) 114 | 115 | let peek_back_at deque n = 116 | let length = deque.front_length + deque.back_length in 117 | if (n < 0) || (n >= length) then raise InvalidIndex 118 | else if n < deque.back_length then List.nth deque.back n 119 | else List.nth deque.front (length - 1 - n) 120 | 121 | let rec set_front_at deque item n = 122 | if n = 0 then enqueue_front (dequeue_front deque) item 123 | else enqueue_front (set_front_at (dequeue_front deque) item (n - 1)) (peek_front deque) 124 | 125 | let rec set_back_at deque item n = 126 | if n = 0 then enqueue_back (dequeue_back deque) item 127 | else enqueue_back (set_back_at (dequeue_back deque) item (n - 1)) (peek_back deque) 128 | 129 | let rec merge d1 d2 = 130 | if is_empty d1 then d2 131 | else if is_empty d2 then d1 132 | else if (length d1) < (length d2) then 133 | merge (dequeue_front d1) (enqueue_back d2 (peek_front d1)) 134 | else 135 | merge (enqueue_front d1 (peek_back d2)) (dequeue_back d2) 136 | 137 | let split deque c = 138 | let rec move d1 d2 = 139 | if (length d1) = c then (d1, d2) 140 | else move (enqueue_front d1 (peek_back d2)) (dequeue_back d2) in 141 | move empty deque 142 | -------------------------------------------------------------------------------- /lib/frame.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Iff 3 | open Type 4 | 5 | type t = 6 | { 7 | stack : Evaluation_stack.t; 8 | local_store : Local_store.t; 9 | called : instruction_address; 10 | resume_at : instruction_address; 11 | store : variable_location option 12 | } 13 | 14 | let make pc = 15 | { 16 | stack = Evaluation_stack.empty; 17 | local_store = Local_store.empty; 18 | called = pc; 19 | resume_at = Instruction 0; 20 | store = None 21 | } 22 | 23 | let make_call_frame story arguments routine_address resume_at store = 24 | let default_store = Local_store.create_default_locals story routine_address in 25 | let local_store = Local_store.write_arguments default_store arguments in 26 | let called = Routine.first_instruction story routine_address in 27 | { 28 | stack = Evaluation_stack.empty; 29 | local_store; 30 | called; 31 | resume_at; 32 | store 33 | } 34 | 35 | let called frame = 36 | frame.called 37 | 38 | let resume_at frame = 39 | frame.resume_at 40 | 41 | let store frame = 42 | frame.store 43 | 44 | let peek_stack frame = 45 | Evaluation_stack.peek frame.stack 46 | 47 | let pop_stack frame = 48 | { frame with stack = Evaluation_stack.pop frame.stack } 49 | 50 | let push_stack frame value = 51 | { frame with stack = Evaluation_stack.push frame.stack value } 52 | 53 | let write_local frame local value = 54 | { frame with local_store = Local_store.write_local frame.local_store local value } 55 | 56 | let read_local frame local = 57 | Local_store.read_local frame.local_store local 58 | 59 | (* Handy debugging methods *) 60 | 61 | let display_frame frame = 62 | let (Instruction called) = frame.called in 63 | let (Instruction resume_at) = frame.resume_at in 64 | Printf.sprintf "Locals %s\nStack %s\nResume at:%04x\nCurrent Routine: %04x\n" 65 | (Local_store.display_locals frame.local_store) 66 | (Evaluation_stack.display_stack frame.stack) 67 | resume_at 68 | called 69 | 70 | let make_frame_record frame = 71 | let locals = Local_store.make_locals_record frame.local_store in 72 | let stack = Evaluation_stack.make_stack_records frame.stack in 73 | let arguments_byte = (1 lsl frame.local_store.Local_store.arguments_supplied) - 1 in 74 | let (Instruction resume_at) = frame.resume_at in 75 | (* TODO Move this into the Quetzal module *) 76 | let (discard_value, target_variable) = 77 | match frame.store with 78 | | None -> (true, 0) 79 | | Some Stack -> (false, 0) 80 | | Some Local_variable Local n -> (false, n) 81 | | Some Global_variable Global n -> (false, n) in 82 | 83 | (* TODO: Bit_number could take a bit number, not an integer *) 84 | Record [ 85 | Integer24 (Some resume_at); 86 | BitField [ 87 | Integer4 (Some (List.length locals)); 88 | Bit (4, Some discard_value)]; 89 | Integer8 (Some target_variable); 90 | BitField [ 91 | Bit (0, Some (fetch_bit (Bit_number 0) arguments_byte)); 92 | Bit (1, Some (fetch_bit (Bit_number 1) arguments_byte)); 93 | Bit (2, Some (fetch_bit (Bit_number 2) arguments_byte)); 94 | Bit (3, Some (fetch_bit (Bit_number 3) arguments_byte)); 95 | Bit (4, Some (fetch_bit (Bit_number 4) arguments_byte)); 96 | Bit (5, Some (fetch_bit (Bit_number 5) arguments_byte)); 97 | Bit (6, Some (fetch_bit (Bit_number 6) arguments_byte))]; 98 | Integer16 (Some (Evaluation_stack.length frame.stack)); 99 | SizedList (Integer8 (Some (List.length locals)), locals ); 100 | SizedList (Integer8 (Some (Evaluation_stack.length frame.stack)) , stack)] 101 | 102 | let make_frame_from_record frame_record = 103 | let (ret_addr, locals_list, eval_stack, 104 | store, arg_count, locals_count) = 105 | match frame_record with 106 | | Record [ 107 | Integer24 (Some ret_addr); 108 | BitField [ 109 | Integer4 (Some locals_count); 110 | Bit (4, Some discard_value)]; 111 | Integer8 (Some target_variable); 112 | BitField [ 113 | Bit (0, Some a0); 114 | Bit (1, Some a1); 115 | Bit (2, Some a2); 116 | Bit (3, Some a3); 117 | Bit (4, Some a4); 118 | Bit (5, Some a5); 119 | Bit (6, Some a6)]; 120 | Integer16 (Some _); (* size of evaluation stack in words *) 121 | SizedList (_, locals_list); 122 | SizedList (_, eval_stack)] -> 123 | let rec find_false n items = 124 | match items with 125 | | false :: _ -> n 126 | | true :: tail -> find_false (n + 1) tail 127 | | [] -> failwith "impossible" in 128 | let arg_count = 129 | find_false 0 [a0; a1; a2; a3; a4; a5; a6; false] in 130 | let store = (* TODO: Use decode_variable *) 131 | match (discard_value, target_variable) with 132 | | (true, _) -> None 133 | | (false, n) -> Some (Instruction.decode_variable n) in 134 | 135 | (Instruction ret_addr, locals_list, eval_stack, 136 | store, arg_count, locals_count) 137 | | _ -> failwith "TODO handle failure reading frame" in 138 | let stack = Evaluation_stack.make_stack_from_record eval_stack in 139 | let local_store = Local_store.make_locals_from_record arg_count locals_list in 140 | { stack; 141 | local_store; 142 | called = Instruction 0; 143 | resume_at = ret_addr ; 144 | store 145 | } 146 | -------------------------------------------------------------------------------- /lib/zstring.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | type string_state = 5 | | Alphabet of int 6 | | Abbrev of abbreviation_number 7 | | Leading 8 | | Trailing of int 9 | 10 | let alphabet0 = Alphabet 0 11 | let alphabet1 = Alphabet 1 12 | let alphabet2 = Alphabet 2 13 | let abbrev0 = Abbrev (Abbreviation 0) 14 | let abbrev32 = Abbrev (Abbreviation 32) 15 | let abbrev64 = Abbrev (Abbreviation 64) 16 | 17 | let alphabet_table = [| 18 | [| " "; "?"; "?"; "?"; "?"; "?"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; 19 | "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z" |]; 20 | [| " "; "?"; "?"; "?"; "?"; "?"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; 21 | "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z" |]; 22 | [| " "; "?"; "?"; "?"; "?"; "?"; "?"; "\n"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; 23 | "8"; "9"; "."; ","; "!"; "?"; "_"; "#"; "'"; "\""; "/"; "\\"; "-"; ":"; "("; ")" |] |] 24 | 25 | (* gives the length in bytes of the encoded zstring, not the decoded string *) 26 | let length story (Zstring address) = 27 | let rec aux len current = 28 | if fetch_bit bit15 (Story.read_word story current) then len + 2 29 | else aux (len + 2) (inc_word_addr current) in 30 | aux 0 (Word_address address) 31 | 32 | let abbreviation_table_length = 96 33 | 34 | (* A "word address" is only used in the abbreviation table, and is always 35 | just half the real address. A "packed address" is used in calls and fetching 36 | strings, and is half the real address in v3 but different for other versions. *) 37 | 38 | let decode_word_address (Word_zstring word_address) = 39 | Zstring (word_address * 2) 40 | 41 | let first_abbrev_addr (Abbreviation_table_base base) = 42 | Word_address base 43 | 44 | let abbreviation_zstring story (Abbreviation n) = 45 | if n < 0 || n >= abbreviation_table_length then 46 | failwith "bad offset into abbreviation table" 47 | else 48 | let base = first_abbrev_addr (Story.abbreviations_table_base story) in 49 | let abbr_addr = inc_word_addr_by base n in 50 | let word_addr = Word_zstring (Story.read_word story abbr_addr) in 51 | decode_word_address word_addr 52 | 53 | let rec read story (Zstring address) = 54 | (* TODO: Only processes version 3 strings *) 55 | 56 | (* zstrings encode three characters into two-byte words. 57 | 58 | The high bit is the end-of-string marker, followed by three 59 | five-bit zchars. 60 | 61 | The meaning of the next zchar(s) depends on the current. 62 | 63 | If the current zchar is 1, 2 or 3 then the next is an offset 64 | into the abbreviation table; fetch the string indicated there. 65 | 66 | If the current zchar is 4 or 5 then the next is an offset into the 67 | uppercase or punctuation alphabets, except if the current is 5 68 | and the next is 6. In that case the two zchars following are a single 69 | 10-bit character. *) 70 | 71 | let process_zchar (Zchar zchar) state = 72 | match (zchar, state) with 73 | | (1, Alphabet _) -> ("", abbrev0) 74 | | (2, Alphabet _) -> ("", abbrev32) 75 | | (3, Alphabet _) -> ("", abbrev64) 76 | | (4, Alphabet _) -> ("", alphabet1) 77 | | (5, Alphabet _) -> ("", alphabet2) 78 | | (6, Alphabet 2) -> ("", Leading) 79 | | (_, Alphabet a) -> (alphabet_table.(a).(zchar), alphabet0) 80 | | (_, Abbrev Abbreviation a) -> 81 | let abbrv = Abbreviation (a + zchar) in 82 | let addr = abbreviation_zstring story abbrv in 83 | let str = read story addr in 84 | (str, alphabet0) 85 | | (_, Leading) -> ("", (Trailing zchar)) 86 | | (_, Trailing high) -> 87 | let s = string_of_char (Char.chr (high * 32 + zchar)) in 88 | (s, alphabet0) in 89 | 90 | let rec aux acc state1 current_address = 91 | let zchar_bit_size = size5 in 92 | let word = Story.read_word story current_address in 93 | let is_end = fetch_bit bit15 word in 94 | let zchar1 = Zchar (fetch_bits bit14 zchar_bit_size word) in 95 | let zchar2 = Zchar (fetch_bits bit9 zchar_bit_size word) in 96 | let zchar3 = Zchar (fetch_bits bit4 zchar_bit_size word) in 97 | let (text1, state2) = process_zchar zchar1 state1 in 98 | let (text2, state3) = process_zchar zchar2 state2 in 99 | let (text3, state_next) = process_zchar zchar3 state3 in 100 | let new_acc = acc ^ text1 ^ text2 ^ text3 in 101 | if is_end then new_acc 102 | else aux new_acc state_next (inc_word_addr current_address) in 103 | aux "" alphabet0 (Word_address address) 104 | 105 | (* A debugging method for looking at memory broken up into the 106 | 1 / 5 / 5 / 5 bit chunks used by zstrings. *) 107 | 108 | let display_bytes story (Zstring addr) = 109 | let rec aux current acc = 110 | let word = Story.read_word story current in 111 | let is_end = fetch_bits bit15 size1 word in 112 | let zchar1 = fetch_bits bit14 size5 word in 113 | let zchar2 = fetch_bits bit9 size5 word in 114 | let zchar3 = fetch_bits bit4 size5 word in 115 | let s = Printf.sprintf "%02x %02x %02x " zchar1 zchar2 zchar3 in 116 | let acc = acc ^ s in 117 | if is_end = 1 then acc 118 | else aux (inc_word_addr current) acc in 119 | aux (Word_address addr) "" 120 | 121 | (* Debugging helper *) 122 | let display_abbreviation_table story = 123 | let to_string i = 124 | let address = abbreviation_zstring story (Abbreviation i) in 125 | let value = read story address in 126 | let (Zstring address) = address in 127 | Printf.sprintf "%02x: %04x %s\n" i address value in 128 | accumulate_strings_loop to_string 0 abbreviation_table_length 129 | -------------------------------------------------------------------------------- /unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Type 3 | 4 | module Main 5 | (KV: Mirage_kv_lwt.RO) 6 | (S: Mirage_stack_lwt.V4) = struct 7 | 8 | let log_new flow = 9 | let dst, dst_port = S.TCPV4.dst flow in 10 | Logs.info (fun f -> f "[%a:%d] New connection" 11 | Ipaddr.V4.pp dst dst_port) 12 | 13 | let log_read_err flow e = 14 | let dst, dst_port = S.TCPV4.dst flow in 15 | Logs.warn (fun f -> f "[%a:%d] Read error: %a, closing connection" 16 | Ipaddr.V4.pp dst dst_port S.TCPV4.pp_error e) 17 | 18 | let log_write_err flow e = 19 | let dst, dst_port = S.TCPV4.dst flow in 20 | Logs.warn (fun f -> f "[%a:%d] Write error: %a, closing connection" 21 | Ipaddr.V4.pp dst dst_port S.TCPV4.pp_write_error e) 22 | 23 | let log_closing flow = 24 | let dst, dst_port = S.TCPV4.dst flow in 25 | Logs.info (fun f -> f "[%a:%d] Closing connection" 26 | Ipaddr.V4.pp dst dst_port) 27 | 28 | let write_string flow s = 29 | (* Logs.info (fun f -> f "Output: %S" s); *) 30 | S.TCPV4.write flow (Server.encode (Cstruct.of_string s)) 31 | 32 | let draw_screen flow screen = 33 | let rec aux n = 34 | let (Character_height h) = Screen.height screen in 35 | if n < h then ( 36 | let text = Screen.get_line_at screen (Character_y (n + 1)) in 37 | write_string flow text >>= function 38 | | Error e -> (* TODO: We should terminate execution here *) 39 | log_write_err flow e; S.TCPV4.close flow 40 | | Ok () -> 41 | aux (n + 1)) 42 | else Lwt.return_unit 43 | in 44 | aux 0 45 | 46 | let draw_interpreter flow interpreter : unit Lwt.t = 47 | let screen = Interpreter.screen interpreter in 48 | let state = Interpreter.state interpreter in 49 | let input = Interpreter.input interpreter in 50 | let has_new_output = Interpreter.has_new_output interpreter in 51 | if state = Interpreter.Waiting_for_input then 52 | draw_screen flow (Screen.fully_scroll (Screen.print screen input)) 53 | else if has_new_output then 54 | let screen_to_draw = 55 | if Screen.needs_more screen then 56 | Screen.more screen 57 | else 58 | screen in 59 | draw_screen flow screen_to_draw 60 | else 61 | Lwt.return_unit 62 | 63 | let start kv s : unit Lwt.t = 64 | 65 | (* Run a single Interpreter step *) 66 | let rec session_step flow telnet interpreter input : unit Lwt.t = 67 | 68 | let rec read_more_input telnet = 69 | S.TCPV4.read flow >>= function 70 | | Ok `Eof -> 71 | Lwt.return None 72 | | Error e -> 73 | log_read_err flow e; Lwt.return None 74 | | Ok (`Data b) -> 75 | let telnet, events, out = Server.handle telnet b in 76 | S.TCPV4.write flow out >>= function 77 | | Error e -> 78 | log_write_err flow e; Lwt.return None 79 | | Ok () -> 80 | let read_characters = List.fold_left (fun acc event -> 81 | match event with 82 | | `Resize (_w, _h) -> 83 | acc (* TODO *) 84 | | `Data bytes -> 85 | let s = Cstruct.to_string bytes in 86 | let chars = Array.make (String.length s) ' ' in 87 | String.iteri (fun i c -> chars.(i) <- c) s; 88 | Array.to_list chars @ acc) [] events 89 | in 90 | match read_characters with 91 | | [] -> 92 | read_more_input telnet 93 | | _ -> 94 | Lwt.return (Some (telnet, read_characters)) 95 | in 96 | 97 | let run = match Interpreter.state interpreter with 98 | | Interpreter.Running -> 99 | Lwt.return (Some (telnet, Interpreter.step interpreter, input)) 100 | | Interpreter.Waiting_for_input -> 101 | begin 102 | match input with 103 | | [] -> 104 | read_more_input telnet >>= begin function 105 | | None -> Lwt.return None 106 | | Some (telnet, input) -> 107 | (* Logs.info (fun f -> f 108 | "Input: %a" Fmt.(list ~sep:(unit ",") char) input); *) 109 | Lwt.return (Some (telnet, interpreter, input)) 110 | end 111 | | ch :: tl -> 112 | Lwt.return (Some 113 | (telnet, Interpreter.step_with_input interpreter ch, tl)) 114 | end 115 | | Interpreter.Halted -> 116 | Lwt.return None 117 | in 118 | 119 | run >>= function 120 | | None -> 121 | log_closing flow; S.TCPV4.close flow 122 | | Some (new_telnet, new_interpreter, input) -> 123 | draw_interpreter flow new_interpreter >>= fun () -> 124 | session_step flow new_telnet new_interpreter input 125 | 126 | (* Handle a new connection; setup the Interpreter *) 127 | and session_start kv flow telnet = 128 | log_new flow; 129 | let get_story_content filename = 130 | KV.get kv (Mirage_kv.Key.v filename) >|= function 131 | | Error _e -> 132 | failwith "could not get story from KV" 133 | | Ok file -> 134 | file 135 | in 136 | get_story_content "MiniZork.Z3" >>= fun story_content -> 137 | let story = Story.load story_content in 138 | let screen = Screen.make (Character_height 50) (Character_width 80) in 139 | let interpreter = Interpreter.make story screen in 140 | session_step flow telnet interpreter [] 141 | 142 | in 143 | let port = Key_gen.port () in 144 | Logs.info (fun m -> m "Listening on [%a:%d]" 145 | Fmt.(list Ipaddr.V4.pp) (S.(IPV4.get_ip @@ ipv4 s)) port); 146 | S.listen_tcpv4 s ~port (fun flow -> 147 | let telnet, out = Server.init () in 148 | S.TCPV4.write flow out >>= function 149 | | Error e -> 150 | log_write_err flow e; S.TCPV4.close flow 151 | | Ok () -> 152 | session_start kv flow telnet 153 | ); 154 | 155 | S.listen s 156 | end 157 | -------------------------------------------------------------------------------- /lib/type.ml: -------------------------------------------------------------------------------- 1 | type byte_address = Byte_address of int 2 | type word_address = Word_address of int 3 | type input_buffer = Input_buffer of int 4 | type parse_buffer = Parse_buffer of int 5 | type string_address = String_address of int 6 | type sz_address = Sz_address of int 7 | type word_prefixed = Word_prefixed_string of int 8 | type byte_prefixed = Byte_prefixed_string of int 9 | type bit_number = Bit_number of int 10 | type object_base = Object_base of int 11 | type property_defaults_table = Property_defaults_table of int 12 | type object_tree_base = Object_tree_base of int 13 | type object_number = Object of int 14 | type object_address = Object_address of int 15 | type property_number = Property of int 16 | type property_header_address = Property_header of int 17 | type property_address = Property_address of int 18 | type property_data_address = Property_data of int 19 | type attribute_number = Attribute of int 20 | type attribute_address = Attribute_address of byte_address * bit_number 21 | type global_table_base = Global_table_base of int 22 | type dictionary_number = Dictionary of int 23 | type dictionary_address = Dictionary_address of int 24 | type routine_address = Routine of int 25 | type packed_routine_address = Packed_routine of int 26 | type packed_zstring_address = Packed_zstring of int 27 | type word_zstring_address = Word_zstring of int 28 | type local_variable = Local of int 29 | type global_variable = Global of int 30 | type instruction_address = Instruction of int 31 | type abbreviation_number = Abbreviation of int 32 | type zstring_address = Zstring of int 33 | type zchar = Zchar of int 34 | type status_line = Status of string option 35 | type character_width = Character_width of int 36 | type character_height = Character_height of int 37 | type character_x = Character_x of int 38 | type character_y = Character_y of int 39 | type pixel_width = Pixel_width of int 40 | type pixel_height = Pixel_height of int 41 | type pixel_x = Pixel_x of int 42 | type pixel_y = Pixel_y of int 43 | type cursor = Cursor of character_x * character_y 44 | type checksum = Checksum of int 45 | type colours_supported = Colours_supported of bool 46 | type pictures_supported = Pictures_supported of bool 47 | type boldface_supported = Boldface_supported of bool 48 | type italics_supported = Italics_supported of bool 49 | type fixed_pitch_supported = Fixed_pitch_supported of bool 50 | type tandy_mode_enabled = Tandy_mode_enabled of bool 51 | type screen_split_supported = Screen_split_supported of bool 52 | type status_line_supported = Status_line_supported of bool 53 | type sound_effects_supported = Sound_effects_supported of bool 54 | type default_pitch = Default_is_variable_pitch of bool 55 | type timed_keyboard_supported = Timed_keyboard_supported of bool 56 | type transcript_enabled = Transcript_enabled of bool 57 | type force_fixed_pitch = Force_fixed_pitch of bool 58 | type draw_status_requested = Draw_status_requested of bool 59 | type pictures_requested = Pictures_requested of bool 60 | type undo_requested = Undo_requested of bool 61 | type mouse_requested = Mouse_requested of bool 62 | type colours_requested = Colours_requested of bool 63 | type sound_requested = Sound_requested of bool 64 | type menus_requested = Menus_requested of bool 65 | type release_number = Release_number of int 66 | type high_memory_base = High_memory_base of int 67 | type static_memory_base = Static_memory_base of int 68 | type dictionary_base = Dictionary_base of int 69 | type dictionary_table_base = Dictionary_table_base of int 70 | type serial_number = Serial_number of string 71 | type abbrev_table_base = Abbreviation_table_base of int 72 | type file_size = File_size of int 73 | type interpreter_number = Interpreter_number of int 74 | type interpreter_version = Interpreter_version of int 75 | type colour_number = Colour of int 76 | type terminating_characters_base = Terminating_characters_base of int 77 | type revision = Revision of int * int 78 | type alphabet_table = Alphabet_table of int 79 | type compressed_bytes = Compressed of string 80 | type uncompressed_bytes = Uncompressed of string 81 | type word_separator_number = Word_separator_number of int 82 | 83 | 84 | type version = 85 | | V1 | V2 | V3 | V4 | V5 | V6 | V7 | V8 86 | 87 | type variable_location = 88 | | Stack 89 | | Local_variable of local_variable 90 | | Global_variable of global_variable 91 | 92 | type operand = 93 | | Large of int 94 | | Small of int 95 | | Variable of variable_location 96 | 97 | type branch_address = 98 | | Return_true 99 | | Return_false 100 | | Branch_address of instruction_address 101 | 102 | type status_line_kind = 103 | | NoStatus 104 | | ScoreStatus 105 | | TimeStatus 106 | 107 | type window_selection = 108 | | Upper_window 109 | | Lower_window 110 | 111 | (* TODO: Make these of bool *) 112 | type scroll_enabled = 113 | | Scroll_enabled 114 | | Scroll_disabled 115 | 116 | type wrap_enabled = 117 | | Word_wrap_enabled 118 | | Word_wrap_disabled 119 | 120 | type more_enabled = 121 | | More_enabled 122 | | More_disabled 123 | 124 | type scroll_pending = 125 | | Scroll_pending of string 126 | | Nothing_pending 127 | 128 | 129 | 130 | type bytecode = 131 | | OP2_1 | OP2_2 | OP2_3 | OP2_4 | OP2_5 | OP2_6 | OP2_7 132 | | OP2_8 | OP2_9 | OP2_10 | OP2_11 | OP2_12 | OP2_13 | OP2_14 | OP2_15 133 | | OP2_16 | OP2_17 | OP2_18 | OP2_19 | OP2_20 | OP2_21 | OP2_22 | OP2_23 134 | | OP2_24 | OP2_25 | OP2_26 | OP2_27 | OP2_28 135 | | OP1_128 | OP1_129 | OP1_130 | OP1_131 | OP1_132 | OP1_133 | OP1_134 | OP1_135 136 | | OP1_136 | OP1_137 | OP1_138 | OP1_139 | OP1_140 | OP1_141 | OP1_142 | OP1_143 137 | | OP0_176 | OP0_177 | OP0_178 | OP0_179 | OP0_180 | OP0_181 | OP0_182 | OP0_183 138 | | OP0_184 | OP0_185 | OP0_186 | OP0_187 | OP0_188 | OP0_189 | OP0_190 | OP0_191 139 | | VAR_224 | VAR_225 | VAR_226 | VAR_227 | VAR_228 | VAR_229 | VAR_230 | VAR_231 140 | | VAR_232 | VAR_233 | VAR_234 | VAR_235 | VAR_236 | VAR_237 | VAR_238 | VAR_239 141 | | VAR_240 | VAR_241 | VAR_242 | VAR_243 | VAR_244 | VAR_245 | VAR_246 | VAR_247 142 | | VAR_248 | VAR_249 | VAR_250 | VAR_251 | VAR_252 | VAR_253 | VAR_254 | VAR_255 143 | | EXT_0 | EXT_1 | EXT_2 | EXT_3 | EXT_4 | EXT_5 | EXT_6 | EXT_7 144 | | EXT_8 | EXT_9 | EXT_10 | EXT_11 | EXT_12 | EXT_13 | EXT_14 145 | | EXT_16 | EXT_17 | EXT_18 | EXT_19 | EXT_20 | EXT_21 | EXT_22 | EXT_23 146 | | EXT_24 | EXT_25 | EXT_26 | EXT_27 | EXT_28 | EXT_29 147 | | ILLEGAL 148 | -------------------------------------------------------------------------------- /lib/tokeniser.ml: -------------------------------------------------------------------------------- 1 | open Type 2 | 3 | type token = 4 | { 5 | token_text : string; 6 | start : int; (* Offset in the input text *) 7 | dictionary_address : dictionary_address 8 | } 9 | 10 | (* TODO: Get word separator list from story *) 11 | 12 | (* Returns a list of tuples containing each word, the start location 13 | in the input string and the address of the matching dictionary word. *) 14 | let tokenise story text = 15 | let length = String.length text in 16 | 17 | let rec find_space_or_end i = 18 | if i = length then i 19 | else if text.[i] = ' ' then i 20 | else find_space_or_end (i + 1) in 21 | 22 | let rec skip_spaces i = 23 | if i = length then i 24 | else if text.[i] = ' ' then skip_spaces (i + 1) 25 | else i in 26 | 27 | let find_token start = 28 | if start = length then 29 | None 30 | else 31 | let end_of_token = find_space_or_end start in 32 | let token_text = String.sub text start (end_of_token - start) in 33 | let dictionary_address = Dictionary.lookup story token_text in 34 | Some {token_text; start; dictionary_address} in 35 | 36 | let rec aux i acc = 37 | match find_token i with 38 | | None -> acc 39 | | Some ({token_text; start; dictionary_address} as token) -> 40 | let token_length = String.length token_text in 41 | let next_non_space = skip_spaces (i + token_length) in 42 | let new_acc = token :: acc in 43 | aux next_non_space new_acc in 44 | 45 | List.rev (aux (skip_spaces 0) []) 46 | (* End of tokenise*) 47 | 48 | (* TODO: What is the type of address? *) 49 | let write_tokens items address max_parse story = 50 | 51 | (* Spec: 52 | * one 4-byte block is written for each word 53 | * it should stop before going beyond the maximum number of words specified. 54 | * Each block consists of the byte address of the word in the dictionary, 55 | if it is in the dictionary, or 0 if it isn't; followed by a byte giving 56 | the number of letters in the word; and finally a byte giving the position 57 | in the text-buffer of the first letter of the word. *) 58 | 59 | let text_buffer_offset = if Story.v4_or_lower (Story.version story) then 1 else 2 in 60 | let rec aux items address count story = 61 | match items with 62 | | [] -> story 63 | | {token_text; start; dictionary_address} :: tail -> 64 | if count = max_parse then 65 | story 66 | else 67 | let (Dictionary_address dictionary_address) = dictionary_address in 68 | let story = Story.write_word story (Word_address address) dictionary_address in 69 | let story = Story.write_byte story (Byte_address (address + 2)) (String.length token_text) in 70 | let story = Story.write_byte story (Byte_address (address + 3)) (start + text_buffer_offset) in 71 | aux tail (address + 4) (count + 1) story in 72 | aux items address 0 story 73 | 74 | (* TODO: This is wrong; we need to pass in not the trimmed string but the 75 | buffer the trimmed string was written to, that the whole thing may be 76 | parsed again. This will be necessary in order to implement the tokenise 77 | instruction. *) 78 | let write_user_string_to_memory story (Input_buffer text_addr) trimmed = 79 | (* Now we have to write the string into story memory. This is a bit tricky. *) 80 | if Story.v4_or_lower (Story.version story) then 81 | (* Spec: In Versions 1 to 4, ... stored in bytes 1 onward, with a zero 82 | terminator (but without any other terminator, such as a carriage return code). 83 | ---- 84 | This seems straighforward. We write the string starting at byte one, 85 | and terminate it with a zero. *) 86 | Story.write_string_zero_terminate story (Sz_address (text_addr + 1)) trimmed 87 | else 88 | (* Spec: In Versions 5 and later, ... the interpreter stores the number of 89 | characters actually typed in byte 1 (not counting the terminating character), 90 | and the characters themselves in bytes 2 onward (not storing the 91 | terminating character). 92 | Moreover, if byte 1 contains a positive value at the start of the input, 93 | then read assumes that number of characters are left over from an 94 | interrupted previous input, and writes the new characters 95 | after those already there. Note that the interpreter does not redisplay 96 | the characters left over: the game does this, if it wants to. 97 | --- 98 | This part of the specification is again, very confusingly written. I think 99 | the correct interpretation for version 5 is: 100 | * the text buffer consists of two lead bytes and L characters. 101 | * the maximum number of user-supplied characters which may *ever* 102 | be written is L, and it is stored in byte 0 103 | * the number of user-supplied characters *currently* written 104 | is C and is in byte 1 105 | * When writing new text in, the new text is written in starting 106 | C + 2 bytes from the first lead byte. The second lead byte is 107 | then updated so that it always contains the actual number of 108 | user-supplied characters in the buffer. *) 109 | let current_letters = Story.read_byte story (Byte_address (text_addr + 1)) in 110 | let story = Story.write_string story (String_address (text_addr + current_letters + 2)) trimmed in 111 | let length = String.length trimmed in 112 | Story.write_byte story (Byte_address (text_addr + 1)) (current_letters + length) 113 | 114 | (* TODO: Could use some helpers here to better type the parse buffer *) 115 | let lexical_analysis story (Parse_buffer parse_addr) trimmed = 116 | (* Spec: 117 | Initially, byte 0 of the parse-buffer should hold the maximum 118 | number of textual words which can be parsed. (If this is n, the buffer 119 | must be at least 2 + 4*n bytes long to hold the results of the analysis.*) 120 | let maximum_parse = Story.read_byte story (Byte_address parse_addr) in 121 | (* Spec: The interpreter divides the text into words and looks them up in the 122 | dictionary, as described in section 13. *) 123 | let tokens = tokenise story trimmed in 124 | (* Spec: The number of words is written in byte 1 *) 125 | let count = min maximum_parse (List.length tokens) in 126 | let story = Story.write_byte story (Byte_address (parse_addr + 1)) count in 127 | (* Spec: one 4-byte block is written for each word, from byte 2 onwards 128 | (except that it should stop before going beyond the maximum number of words 129 | specified). *) 130 | write_tokens tokens (parse_addr + 2) maximum_parse story 131 | -------------------------------------------------------------------------------- /lib/screen.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | type t = 5 | { 6 | status : status_line; 7 | upper_window : Window.t; 8 | lower_window : Window.t; 9 | height : character_height; 10 | width : character_width; 11 | selected_window : window_selection; 12 | } 13 | 14 | let make height width = 15 | let (Character_height h) = height in 16 | let y = (Character_y h) in 17 | { 18 | status = Status None; 19 | upper_window = Window.make 20 | (Character_height 0) 21 | width 22 | Window.top_left 23 | Word_wrap_disabled 24 | Scroll_disabled 25 | More_disabled; 26 | lower_window = Window.make 27 | height 28 | width 29 | (Cursor (Window.left_column, y)) 30 | Word_wrap_enabled 31 | Scroll_enabled 32 | More_enabled; 33 | height; 34 | width; 35 | selected_window = Lower_window 36 | } 37 | 38 | let width screen = 39 | screen.width 40 | 41 | let height screen = 42 | screen.height 43 | 44 | let status screen = 45 | screen.status 46 | 47 | let set_status screen status = 48 | { screen with status } 49 | 50 | let selected_window screen = 51 | screen.selected_window 52 | 53 | let lines screen = 54 | Window.merge screen.upper_window screen.lower_window 55 | 56 | let get_line_at screen (Character_y y) = 57 | Deque.peek_back_at (lines screen) (y - 1) 58 | 59 | let erase_upper screen = 60 | { screen with upper_window = Window.erase screen.upper_window } 61 | 62 | let erase_lower screen = 63 | { screen with lower_window = Window.erase screen.lower_window } 64 | 65 | let erase_all screen = 66 | erase_upper (erase_lower screen) 67 | 68 | let upper_cursor screen = 69 | Window.cursor screen.upper_window 70 | 71 | let lower_cursor screen = 72 | (* Obtain the location of the lower window cursor in screen coordinates *) 73 | let c = Window.cursor screen.lower_window in 74 | let h = Window.height screen.upper_window in 75 | Window.move_cursor_down c h 76 | 77 | let set_upper_cursor screen cursor = 78 | { screen with upper_window = Window.set_cursor screen.upper_window cursor } 79 | 80 | let set_lower_cursor screen cursor = 81 | (* The cursor here is in screen coordinates; translate to lower window coordinates. *) 82 | let h = Window.height screen.upper_window in 83 | let cursor = Window.move_cursor_up cursor h in 84 | { screen with lower_window = Window.set_cursor screen.lower_window cursor } 85 | 86 | let set_cursor screen cursor = 87 | match screen.selected_window with 88 | | Lower_window -> set_lower_cursor screen cursor 89 | | Upper_window -> set_upper_cursor screen cursor 90 | 91 | let split_window screen new_upper_height = 92 | (* Splitting does not change the contents of the screen, but it can 93 | change what window is selected and where the cursor is. *) 94 | 95 | (* First figure out what lines go in which window. *) 96 | let (Character_height h) = new_upper_height in 97 | let (new_upper_lines, new_lower_lines) = Deque.split (lines screen) h in 98 | let upper_window = Window.set_lines screen.upper_window new_upper_lines in 99 | let lower_window = Window.set_lines screen.lower_window new_lower_lines in 100 | let new_screen = { screen with upper_window; lower_window } in 101 | 102 | (* We have a new screen with the right text in the windows, but the cursors 103 | are possibly wrong. Fix the upper cursor first. *) 104 | let new_screen = 105 | if screen.selected_window = Lower_window then 106 | (* If the lower window is selected when the screen is split then the 107 | upper window cursor is reset to 1, 1. *) 108 | set_upper_cursor new_screen Window.top_left 109 | else 110 | (* Spec 8.7.2.1.1 111 | It is unclear exactly what split_window should do if the upper window is 112 | currently selected. The author suggests that it should work as usual, 113 | leaving the cursor where it is if the cursor is still inside the new upper 114 | window, and otherwise moving the cursor back to the top left. *) 115 | let upper_cursor = upper_cursor screen in 116 | if Window.cursor_in_bounds upper_window upper_cursor then 117 | new_screen 118 | else 119 | set_upper_cursor new_screen Window.top_left in 120 | 121 | (* The upper cursor is now correct, but the lower one is still wrong. *) 122 | 123 | (* Spec 8.7.2.2 124 | If a split takes place which would cause the upper window to swallow the 125 | lower window's cursor position, the interpreter should move the lower 126 | window's cursor down to the line just below the upper window's new size. *) 127 | let new_screen = { new_screen with upper_window; lower_window } in 128 | let original_lower_cursor = lower_cursor screen in 129 | let new_screen = 130 | if Window.cursor_in_bounds upper_window original_lower_cursor then 131 | let new_cursor = Window.set_cursor_y original_lower_cursor (Character_y (h + 1)) in 132 | set_lower_cursor new_screen new_cursor 133 | else 134 | set_lower_cursor new_screen original_lower_cursor in 135 | (* The lower cursor is now in place. Did the window selection change? *) 136 | if h = 0 && screen.selected_window = Upper_window then 137 | { new_screen with selected_window = Lower_window } 138 | else 139 | new_screen 140 | 141 | let set_window screen w = 142 | (* SPEC 8.7.2 Whenever the upper window is selected, its 143 | cursor position is reset to the top left. *) 144 | let s = { screen with selected_window = w } in 145 | if w = Upper_window then set_upper_cursor s Window.top_left 146 | else s 147 | 148 | let print screen text = 149 | match screen.selected_window with 150 | | Lower_window -> 151 | { screen with lower_window = Window.print screen.lower_window text } 152 | | Upper_window -> 153 | { screen with upper_window = Window.print screen.upper_window text } 154 | 155 | let scroll screen = 156 | { screen with lower_window = Window.scroll screen.lower_window } 157 | 158 | let fully_scroll screen = 159 | { screen with lower_window = Window.fully_scroll screen.lower_window } 160 | 161 | let needs_scroll screen = 162 | Window.has_pending screen.lower_window 163 | 164 | let needs_more screen = 165 | Window.needs_more screen.lower_window 166 | 167 | let more screen = 168 | { screen with lower_window = Window.more screen.lower_window } 169 | 170 | let clear_more screen = 171 | { screen with lower_window = Window.clear_more screen.lower_window } 172 | 173 | let erase_line screen = 174 | match screen.selected_window with 175 | | Lower_window -> 176 | { screen with lower_window = Window.erase_line screen.lower_window } 177 | | Upper_window -> 178 | { screen with upper_window = Window.erase_line screen.upper_window } 179 | 180 | let get_active_cursor screen = 181 | match screen.selected_window with 182 | | Lower_window -> Window.cursor screen.lower_window 183 | | Upper_window -> Window.cursor screen.upper_window 184 | 185 | let set_word_wrap screen can_wrap = 186 | let lower_window = Window.set_can_wrap screen.lower_window can_wrap in 187 | { screen with lower_window } 188 | 189 | let set_lower_cursor_bottom_left screen = 190 | let (Character_height h) = screen.height in 191 | let cursor = Cursor (Window.left_column, (Character_y h)) in 192 | set_lower_cursor screen cursor 193 | -------------------------------------------------------------------------------- /lib/utility.ml: -------------------------------------------------------------------------------- 1 | open Type 2 | (* Just some useful stuff that has no good home *) 3 | 4 | module IntMap = Map.Make(struct type t = int let compare = compare end) 5 | 6 | let byte_of_int x = 7 | x land 0xff 8 | 9 | let string_of_char x = 10 | String.make 1 x 11 | 12 | let string_of_byte b = 13 | string_of_char (char_of_int b) 14 | 15 | let truncate text length = 16 | if (String.length text) > length then String.sub text 0 length 17 | else text 18 | 19 | let rec times f n item = 20 | if n = 0 then item else times f (n - 1) (f item) 21 | 22 | let spaces n = 23 | String.make n ' ' 24 | 25 | let rec reverse_index_from text target index = 26 | if index < 0 then None 27 | else if text.[index] = target then Some index 28 | else reverse_index_from text target (index - 1) 29 | 30 | let left_string text length = 31 | String.sub text 0 length 32 | 33 | let right_string text index = 34 | String.sub text index ((String.length text) - index) 35 | 36 | let break_string text target = 37 | let index = String.index text target in 38 | let left = left_string text index in 39 | let right = right_string text (index + 1) in 40 | (left, right) 41 | 42 | let replace_at original_text index new_text = 43 | let len = String.length new_text in 44 | let left = left_string original_text index in 45 | let right = right_string original_text (index + len) in 46 | left ^ new_text ^ right 47 | 48 | let accumulate_strings to_string items = 49 | let folder text item = 50 | text ^ (to_string item) in 51 | List.fold_left folder "" items 52 | 53 | let accumulate_strings_loop to_string start max = 54 | let rec aux acc i = 55 | if i >= max then acc 56 | else aux (acc ^ (to_string i)) (i + 1) in 57 | aux "" start 58 | 59 | let unsigned_word word = 60 | ((word mod 65536) + 65536) mod 65536 61 | 62 | let signed_word word = 63 | let canonical = unsigned_word word in 64 | if canonical > 32767 then canonical - 65536 else canonical 65 | 66 | (* Helper method that takes an item and a function that produces related items. 67 | The result is the transitive closure of the relation. *) 68 | 69 | (* TODO: This is not very efficient because of the call to List.mem in there. 70 | TODO: A solution involving an immutable set would be more performant for 71 | TODO: large closures. *) 72 | 73 | let transitive_closure_many items relation = 74 | let rec merge related set stack = 75 | match related with 76 | | [] -> (set, stack) 77 | | head :: tail -> 78 | if List.mem head set then merge tail set stack 79 | else merge tail (head :: set) (head :: stack) in 80 | let rec aux set stack = 81 | match stack with 82 | | [] -> set 83 | | head :: tail -> 84 | let (new_set, new_stack) = merge (relation head) set tail in 85 | aux new_set new_stack in 86 | aux [] items 87 | 88 | let transitive_closure item relation = 89 | transitive_closure_many [item] relation 90 | 91 | let reflexive_closure_many items relation = 92 | let t = transitive_closure_many items relation in 93 | List.fold_left (fun s i -> if List.mem i s then s else i :: s) t items 94 | 95 | let reflexive_closure item relation = 96 | reflexive_closure_many [item] relation 97 | 98 | 99 | 100 | let bit0 = Bit_number 0 101 | let bit1 = Bit_number 1 102 | let bit2 = Bit_number 2 103 | let bit3 = Bit_number 3 104 | let bit4 = Bit_number 4 105 | let bit5 = Bit_number 5 106 | let bit6 = Bit_number 6 107 | let bit7 = Bit_number 7 108 | let bit8 = Bit_number 8 109 | let bit9 = Bit_number 9 110 | let bit10 = Bit_number 10 111 | let bit11 = Bit_number 11 112 | let bit12 = Bit_number 12 113 | let bit13 = Bit_number 13 114 | let bit14 = Bit_number 14 115 | let bit15 = Bit_number 15 116 | 117 | type bit_size = 118 | Bit_size of int 119 | 120 | let size1 = Bit_size 1 121 | let size2 = Bit_size 2 122 | let size3 = Bit_size 3 123 | let size4 = Bit_size 4 124 | let size5 = Bit_size 5 125 | let size6 = Bit_size 6 126 | let size7 = Bit_size 7 127 | 128 | let fetch_bit (Bit_number n) word = 129 | (word land (1 lsl n)) lsr n = 1 130 | 131 | let clear_bit (Bit_number n) word = 132 | word land (lnot (1 lsl n)) 133 | 134 | let set_bit (Bit_number n) word = 135 | word lor (1 lsl n) 136 | 137 | let set_bit_to n word value = 138 | if value then set_bit n word 139 | else clear_bit n word 140 | 141 | let fetch_bits (Bit_number high) (Bit_size length) word = 142 | let mask = lnot (-1 lsl length) in 143 | (word lsr (high - length + 1)) land mask 144 | 145 | let display_bytes get_byte first length = 146 | let blocksize = 16 in 147 | let to_string i = 148 | let header = 149 | if i mod blocksize = 0 then Printf.sprintf "\n%06x: " i 150 | else "" in 151 | let byte = get_byte (Byte_address i) in 152 | let contents = Printf.sprintf "%02x " byte in 153 | header ^ contents in 154 | (accumulate_strings_loop to_string first (first + length)) ^ "\n" 155 | 156 | let get_file filename = 157 | let channel = open_in_bin filename in 158 | let length = in_channel_length channel in 159 | let file = really_input_string channel length in 160 | close_in channel; 161 | file 162 | 163 | let write_file filename text = 164 | let channel = open_out_bin filename in 165 | output_string channel text; 166 | close_out channel 167 | 168 | let rec first_match items predicate = 169 | match items with 170 | | h :: t -> if predicate h then Some h else first_match t predicate 171 | | [] -> None 172 | 173 | (* Binary search a range. Min is inclusive, max is exclusive. *) 174 | let rec binary_search min max compare = 175 | if min >= max then 176 | None 177 | else 178 | let middle = (min + max) / 2 in 179 | let comparison = compare middle in 180 | if comparison < 0 then binary_search (middle + 1) max compare 181 | else if comparison > 0 then binary_search min middle compare 182 | else Some middle 183 | 184 | let max x y = 185 | if x > y then x else y 186 | 187 | let min x y = 188 | if x < y then x else y 189 | 190 | let word_size = 2 191 | 192 | let inc_byte_addr_by (Byte_address address) offset = 193 | Byte_address (address + offset) 194 | 195 | let dec_byte_addr_by address offset = 196 | inc_byte_addr_by address (0 - offset) 197 | 198 | let inc_byte_addr address = 199 | inc_byte_addr_by address 1 200 | 201 | let inc_word_addr_by (Word_address address) offset = 202 | Word_address (address + offset * word_size) 203 | 204 | let inc_word_addr address = 205 | inc_word_addr_by address 1 206 | 207 | let byte_of_string (String_address address) offset = 208 | Byte_address (address + offset) 209 | 210 | let string_of_sz (Sz_address address) = 211 | String_address address 212 | 213 | let string_of_wps (Word_prefixed_string wps) = 214 | String_address (wps + word_size) 215 | 216 | let length_addr_of_wps (Word_prefixed_string wps) = 217 | Word_address wps 218 | 219 | let string_of_bps (Byte_prefixed_string bps) = 220 | String_address (bps + 1) 221 | 222 | let length_addr_of_bps (Byte_prefixed_string bps) = 223 | Byte_address bps 224 | 225 | let is_in_range (Byte_address address) size = 226 | 0 <= address && address < size 227 | 228 | let is_out_of_range address size = 229 | not (is_in_range address size) 230 | 231 | let dereference_string address bytes = 232 | if is_out_of_range address (String.length bytes) then 233 | failwith "address out of range" 234 | else 235 | let (Byte_address addr) = address in 236 | int_of_char bytes.[addr] 237 | 238 | let address_of_high_byte (Word_address address) = 239 | Byte_address address 240 | 241 | let address_of_low_byte (Word_address address) = 242 | Byte_address (address + 1) 243 | 244 | let byte_addr_to_word_addr (Byte_address address) = 245 | Word_address address 246 | -------------------------------------------------------------------------------- /lib_telnet/server.ml: -------------------------------------------------------------------------------- 1 | open Wire 2 | 3 | type cmd = [ `WILL | `WILL_NOT | `DO | `DO_NOT ] 4 | 5 | let cmd_to_string = function 6 | | `WILL -> "will" 7 | | `WILL_NOT -> "will not" 8 | | `DO -> "do" 9 | | `DO_NOT -> "do not" 10 | 11 | type status = 12 | | Data 13 | | Command 14 | | Option of cmd 15 | | Suboption 16 | | EatSub of int * telnet_option * int list 17 | | SubDone 18 | 19 | let status_to_string = function 20 | | Data -> "data" 21 | | Command -> "cmd" 22 | | Option cmd -> "option " ^ cmd_to_string cmd 23 | | Suboption -> "sub" 24 | | EatSub (n, _, col) -> Printf.sprintf "eatsub %d left, %d collected" n (List.length col) 25 | | SubDone -> "sub done" 26 | 27 | type option_state = [ 28 | | `Requested (* we requested *) 29 | | `Denied (* other side denied *) 30 | | `Accepted (* other side accepted *) 31 | ] 32 | 33 | let option_state_to_string = function 34 | | `Requested -> "requested" 35 | | `Denied -> "denied" 36 | | `Accepted -> "accepted" 37 | 38 | type state = { 39 | machina : status ; 40 | server_config : (cmd * telnet_option) list ; 41 | client_options : (option_state * telnet_option) list ; 42 | } 43 | 44 | let option_to_string (o, t) = 45 | Printf.sprintf "%s %s" (option_state_to_string o) (telnet_option_to_string t) 46 | 47 | let state_to_string s = 48 | Printf.sprintf "state %s options %s\n" 49 | (status_to_string s.machina) 50 | (String.concat ", " (List.map option_to_string s.client_options)) 51 | 52 | let client_option_state s option = 53 | try Some (fst (List.find (fun (_, o) -> o = option) s.client_options)) 54 | with Not_found -> None 55 | 56 | let emit_cmd cmd = 57 | let b = match cmd with 58 | | `WILL -> WILL 59 | | `WILL_NOT -> WILL_NOT 60 | | `DO -> DO 61 | | `DO_NOT -> DO_NOT 62 | in 63 | let c = telnet_command_to_int b in 64 | let b = Cstruct.create 2 in 65 | Cstruct.set_uint8 b 0 0xFF ; 66 | Cstruct.set_uint8 b 1 c ; 67 | b 68 | 69 | let emit_option cmd opt = 70 | let c = telnet_option_to_int opt in 71 | let cs = Cstruct.create 1 in 72 | Cstruct.set_uint8 cs 0 c ; 73 | Cstruct.concat [ emit_cmd cmd; cs ] 74 | 75 | let handle_option state cmd what = 76 | let not_option = List.filter (fun (_, opt) -> opt <> what) state.client_options in 77 | let client_options, out = match cmd, client_option_state state what with 78 | | `WILL, Some `Requested -> (`Accepted, what) :: not_option, [] 79 | | `WILL_NOT, Some `Requested -> (`Denied, what) :: not_option, [] 80 | | `DO_NOT, Some `Requested -> (`Denied, what) :: not_option, [] 81 | | `DO, _ -> state.client_options, [] (*`Option (`WILL_NOT, what)] XXX depends on state *) 82 | | `WILL, _ -> 83 | Printf.printf "requested, but won't %s\n%!" (telnet_option_to_string what) ; 84 | state.client_options, [`Option (`WILL_NOT, what)] 85 | | cmd, _ -> 86 | Printf.printf "ignoring unknown request %s %s\n%!" (cmd_to_string cmd) (telnet_option_to_string what) ; 87 | state.client_options, [] 88 | in 89 | { state with machina = Data ; client_options }, out 90 | 91 | let handle_sub _state = function 92 | | Negotiate_About_Window_Size -> EatSub (4, Negotiate_About_Window_Size, []) 93 | | _ -> Data 94 | 95 | let of_list ints = 96 | let l = List.length ints in 97 | let res = Cstruct.create l in 98 | let rec go idx = function 99 | | x :: xs -> Cstruct.set_uint8 res idx x ; go (succ idx) xs 100 | | [] -> () 101 | in 102 | go 0 ints ; 103 | res 104 | 105 | let handle_subcommand _state cs = function 106 | | Negotiate_About_Window_Size -> 107 | let (width : int) = Cstruct.BE.get_uint16 cs 0 108 | and (height : int) = Cstruct.BE.get_uint16 cs 2 109 | in 110 | [ `Resize (width, height) ] 111 | | _ -> [] 112 | 113 | let handle_command state = 114 | let status machina = { state with machina } in 115 | function 116 | | IAC -> status Data, [`Data 0xFF] 117 | | SUBNEG_END -> status Data, [] 118 | | NOP -> status Data, [] 119 | | WILL -> status (Option `WILL), [] 120 | | WILL_NOT -> status (Option `WILL_NOT), [] 121 | | DO -> status (Option `DO), [] 122 | | DO_NOT -> status (Option `DO_NOT), [] 123 | | SUBNEG -> status Suboption, [] 124 | | x -> 125 | Printf.printf "received %s\n%!" (telnet_command_to_string x) ; 126 | status Data, [] (* this is incorrect *) 127 | 128 | let handle_main state data = 129 | match state.machina, data with 130 | | Data, 0xFF -> { state with machina = Command }, [] 131 | | Data, c -> state, [`Data c] 132 | | Command, cmd -> (match int_to_telnet_command cmd with 133 | | None -> Printf.printf "unknown command %x\n%!" data ; { state with machina = Data }, [] 134 | | Some x -> handle_command state x) 135 | | Option cmd, data -> (match int_to_telnet_option data with 136 | | None -> Printf.printf "unknown option %x\n%!" data ; { state with machina = Data }, [] 137 | | Some x -> handle_option state cmd x) 138 | | Suboption, x -> (match int_to_telnet_option x with 139 | | None -> Printf.printf "unknown suboption %x\n%!" data ; { state with machina = Data }, [] 140 | | Some x -> let machina = handle_sub state x in { state with machina }, []) 141 | | EatSub (1, opt, xs), x -> 142 | let out = handle_subcommand state (of_list (List.rev (x::xs))) opt in 143 | { state with machina = SubDone }, out 144 | | EatSub (x, opt, xs), c -> { state with machina = EatSub (pred x, opt, c :: xs) }, [] 145 | | SubDone, 0xFF -> { state with machina = Command }, [] 146 | | SubDone, x -> { state with machina = Data }, [`Data x] 147 | 148 | let ev_s = function 149 | | `Data c -> Printf.printf "data %d:" (Cstruct.len c) ; Cstruct.hexdump c 150 | | `Resize (w, h) -> Printf.printf "resize %d, %d\n%!" w h 151 | 152 | let handle state buf = 153 | (* Printf.printf "state in %s" (state_to_string state) ; *) 154 | let l = Cstruct.len buf in 155 | let rec go state idx acc = 156 | if idx >= l then 157 | state, List.flatten (List.rev acc) 158 | else 159 | let x = Cstruct.get_uint8 buf idx in 160 | let state, outs = handle_main state x in 161 | go state (succ idx) (outs :: acc) 162 | in 163 | let state, out = go state 0 [] in 164 | let maybe_data e = function 165 | | [] -> e 166 | | xs -> `Data (of_list (List.rev xs)) :: e 167 | in 168 | let data, options, events = List.fold_left ( fun (d, o, e) ev -> 169 | match ev with 170 | | `Option (cmd, x) -> ([], emit_option cmd x :: o, maybe_data e d) 171 | | `Data x -> (x :: d, o, e) 172 | | `Resize (w, h) -> ([], o, maybe_data (`Resize (w, h) :: e) d) ) 173 | ([], [], []) out 174 | in 175 | let events = maybe_data events data in 176 | let options = Cstruct.concat (List.rev options) in 177 | (* Printf.printf "state out %s" (state_to_string state) ; *) 178 | (state, events, options) 179 | 180 | let init () = 181 | let server_config = [ 182 | `DO, Negotiate_About_Window_Size ; 183 | `DO, Binary_Transmission ; 184 | `WILL, Binary_Transmission ; 185 | (* `DO, Remote_Controlled_Trans_and_Echo ; *) 186 | (* `DO, Telnet_Suppress_Local_Echo ; *) 187 | `WILL, Echo ; 188 | (* `DO, Linemode ; *) 189 | (* `DO_NOT, Echo ; *) 190 | (* `DO, Suppress_Go_Ahead ; *) 191 | (* `WILL, Suppress_Go_Ahead ; *) 192 | ] in 193 | let client_options = List.map (fun (_, o) -> (`Requested, o)) server_config in 194 | ({ machina = Data ; server_config ; client_options }, 195 | Cstruct.concat (List.map (fun (c, o) -> emit_option c o) server_config)) 196 | 197 | let encode cs = 198 | let l = Cstruct.len cs in 199 | let res = Cstruct.create (2 * l) in 200 | let off = ref 0 in 201 | for i = 0 to pred l do 202 | match Cstruct.get_uint8 cs i with 203 | | 0xFF -> 204 | Cstruct.BE.set_uint16 res (i + !off) 0xFFFF ; 205 | incr off 206 | | x -> Cstruct.set_uint8 res (i + !off) x 207 | done ; 208 | Cstruct.sub res 0 (l + !off) 209 | -------------------------------------------------------------------------------- /lib/window.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | (* A window is a rectangular block of text with a cursor. Text is 5 | written at the cursor; text which hits the edge of the window is wrapped 6 | either on word or character boundaries. Text written on the bottom line 7 | may cause the window to scroll. Windows keep track of pending text and 8 | will add it to the bottom line when scrolled. A window also knows how 9 | many times it has been scrolled, and lets the host know when it should 10 | be displaying "MORE". *) 11 | 12 | (* Cursor position is one-based; (1, 1) is the top left, 13 | (width, height) is the bottom right. *) 14 | 15 | type t = 16 | { 17 | cursor : cursor; 18 | can_wrap : wrap_enabled; 19 | can_scroll : scroll_enabled; 20 | can_more : more_enabled; 21 | pending : scroll_pending; 22 | lines : string Deque.t; 23 | height : character_height; 24 | width : character_width; 25 | scroll_count : int; 26 | needs_more : bool 27 | } 28 | 29 | let make height width cursor can_wrap can_scroll can_more = 30 | let (Character_width w) = width in 31 | let (Character_height h) = height in 32 | let blank_line = Utility.spaces w in 33 | let add d = 34 | Deque.enqueue_back d blank_line in 35 | { 36 | cursor; 37 | can_wrap; 38 | can_scroll; 39 | can_more; 40 | pending = Nothing_pending; 41 | lines = times add h Deque.empty; 42 | height; 43 | width; 44 | scroll_count = 0; 45 | needs_more = false 46 | } 47 | 48 | let spaces (Character_width w) = 49 | Utility.spaces w 50 | 51 | let blank_line window = 52 | spaces window.width 53 | 54 | let left_column = (Character_x 1) 55 | 56 | let right_column window = 57 | let (Character_width w) = window.width in 58 | (Character_x w) 59 | 60 | let top_row = (Character_y 1) 61 | 62 | let bottom_row window = 63 | let (Character_height h) = window.height in 64 | (Character_y h) 65 | 66 | let top_left = Cursor (left_column, top_row) 67 | 68 | let bottom_left window = 69 | Cursor (left_column, (bottom_row window)) 70 | 71 | let set_cursor_x cursor x = 72 | let Cursor (_, y) = cursor in 73 | Cursor (x, y) 74 | 75 | let set_cursor_y cursor y = 76 | let Cursor (x, _) = cursor in 77 | Cursor (x, y) 78 | 79 | let add_characters_w (Character_width w1) (Character_width w2) = 80 | Character_width (w1 + w2) 81 | 82 | let add_characters_h (Character_height h1) (Character_height h2) = 83 | Character_height (h1 + h2) 84 | 85 | let add_characters_x (Character_x x) (Character_width w) = 86 | Character_x (x + w) 87 | 88 | let add_characters_y (Character_y y) (Character_height h) = 89 | Character_y (y + h) 90 | 91 | let add_characters_y_bounded (Character_y y) (Character_height b) (Character_height h) = 92 | let y = y + h in 93 | let y = max y 1 in 94 | let y = min y b in 95 | Character_y y 96 | 97 | let add_characters_x_bounded (Character_x x) (Character_width b) (Character_width w) = 98 | let x = x + w in 99 | let x = max x 1 in 100 | let x = min x b in 101 | Character_x x 102 | 103 | let add_characters_y_bounded (Character_y y) (Character_height b) (Character_height h) = 104 | let y = y + h in 105 | let y = max y 1 in 106 | let y = min y b in 107 | Character_y y 108 | 109 | let move_window_cursor_x window w = 110 | let Cursor (x, y) = window.cursor in 111 | let x = add_characters_x_bounded x window.width w in 112 | { window with cursor = Cursor (x, y) } 113 | 114 | let move_window_cursor_y window h = 115 | let Cursor (x, y) = window.cursor in 116 | let y = add_characters_y_bounded y window.height h in 117 | { window with cursor = Cursor (x, y) } 118 | 119 | let move_cursor_down cursor h = 120 | let Cursor (_, y) = cursor in 121 | set_cursor_y cursor (add_characters_y y h) 122 | 123 | let move_cursor_up cursor (Character_height h) = 124 | let h = Character_height (0 - h) in 125 | move_cursor_down cursor h 126 | 127 | let return_cursor window = 128 | let window = move_window_cursor_y window (Character_height 1) in 129 | let cursor = set_cursor_x window.cursor left_column in 130 | { window with cursor } 131 | 132 | let erase window = 133 | let (Character_height h) = window.height in 134 | let blank_line = blank_line window in 135 | let add d = 136 | Deque.enqueue_back d blank_line in 137 | { window with lines = times add h Deque.empty } 138 | 139 | let set_cursor window cursor = 140 | { window with cursor } 141 | 142 | let cursor_at_bottom window = 143 | let Cursor (_, y) = window.cursor in 144 | y = (bottom_row window) 145 | 146 | let set_window_cursor_top_left window = 147 | set_cursor window top_left 148 | 149 | let set_window_cursor_bottom_left window = 150 | set_cursor window (bottom_left window) 151 | 152 | let carriage_return window = 153 | (* We are logically executing a carriage return. There are several 154 | cases to consider. *) 155 | 156 | (* Easy case: If we are in the middle of the window, just bump it down 157 | one line and go all the way to the left. *) 158 | if not (cursor_at_bottom window) then 159 | return_cursor window 160 | 161 | (* We are at the bottom of the window. Second easy case: if the window cannot 162 | scroll then it simply stays put. *) 163 | else if window.can_scroll = Scroll_disabled then 164 | window 165 | 166 | (* We are at the bottom of the window and we can scroll. There are two 167 | remaining cases: if there is no pending input yet then make a blank 168 | pending input; this is the "what will be printed on the next line when 169 | we scroll" case. *) 170 | 171 | (* Otherwise, we already have a bunch of pending text to process. Simply 172 | add a carriage return to that and the print logic will deal with it later. *) 173 | else 174 | match window.pending with 175 | | Nothing_pending -> 176 | { window with pending = Scroll_pending "" } 177 | | Scroll_pending text -> 178 | { window with pending = Scroll_pending (text ^ "\n") } 179 | 180 | let get_line window (Character_y y) = 181 | let (Character_height h) = window.height in 182 | Deque.peek_front_at window.lines (h - y) 183 | 184 | let set_line window line (Character_y y) = 185 | let (Character_height h) = window.height in 186 | let lines = Deque.set_front_at window.lines line (h - y) in 187 | { window with lines } 188 | 189 | let left_in_line window = 190 | let Cursor ((Character_x x), _) = window.cursor in 191 | let (Character_width w) = window.width in 192 | Character_width (w - x + 1) 193 | 194 | let has_room_for window text = 195 | let (Character_width remaining) = left_in_line window in 196 | let len = String.length text in 197 | len < remaining 198 | 199 | let current_line window = 200 | let Cursor (_, y) = window.cursor in 201 | get_line window y 202 | 203 | let replace_text window text = 204 | let len = Character_width (String.length text) in 205 | let Cursor ((Character_x x), y) = window.cursor in 206 | let line = current_line window in 207 | let new_line = replace_at line (x - 1) text in 208 | let window = set_line window new_line y in 209 | move_window_cursor_x window len 210 | 211 | let erase_line window = 212 | let Cursor ((Character_x x), y) = window.cursor in 213 | let old_line = get_line window y in 214 | let left = left_string old_line (x - 1) in 215 | let (Character_width w) = window.width in 216 | let right = spaces (Character_width (w - x + 1)) in 217 | set_line window (left ^ right) y 218 | 219 | let find_break_index window text = 220 | let (Character_width w) = window.width in 221 | if window.can_wrap = Word_wrap_enabled then 222 | let space_location = reverse_index_from text ' ' (w - 1) in 223 | match space_location with 224 | | None -> (w - 1) 225 | | Some location -> location 226 | else 227 | (w - 1) 228 | 229 | let line_left_of_cursor window = 230 | let Cursor ((Character_x x), y) = window.cursor in 231 | let line = get_line window y in 232 | left_string line (x - 1) 233 | 234 | let rec print window text = 235 | let len = String.length text in 236 | if len = 0 then 237 | (* Base case: string we're adding is empty -> no change *) 238 | window 239 | else match window.pending with 240 | | Scroll_pending p -> 241 | (* Base case: we are already buffering output; just add to 242 | the buffer. *) 243 | { window with pending = Scroll_pending (p ^ text) } 244 | | _ -> 245 | let Cursor ((Character_x x), y) = window.cursor in 246 | let (Character_width w) = window.width in 247 | if String.contains text '\n' then 248 | (* Recursive case: If the string contains newlines, break it 249 | at the newline and print both resulting strings *) 250 | let (left, right) = break_string text '\n' in 251 | print (carriage_return (print window left)) right 252 | else if has_room_for window text then 253 | (* Base case: if we are writing text that entirely fits on the 254 | current line then replace the portion of the current line 255 | at the current cursor position. *) 256 | replace_text window text 257 | else 258 | (* Recursive case: the text does not fit on the current line. *) 259 | (* Construct the line that is too long for the screen *) 260 | let over_length_line = (line_left_of_cursor window) ^ text in 261 | (* Figure out where we can break this line. If wrapping, find a space 262 | that would be on the screen. If there is none, or we're not wrapping 263 | then just break at the edge of the screen. *) 264 | let break_index = find_break_index window over_length_line in 265 | (* We need to rewrite the entire line. If a previous write ended 266 | the line with "AAA BBB" and then CCC was written, with no spaces, 267 | we might have to move BBBCCC down to the next line. *) 268 | let left = left_string over_length_line (break_index + 1) in 269 | let blank_line = Utility.spaces (w - break_index - 1) in 270 | let new_line = left ^ blank_line in 271 | let right = right_string over_length_line (break_index + 1) in 272 | (* and then the unwritten remainder is dealt with recursively. *) 273 | print (carriage_return (set_line window new_line y)) right 274 | 275 | let scroll window = 276 | (* To scroll a window we lose the top line and add 277 | a new blank line. The cursor is positioned at the 278 | bottom left corner. If there is buffered text pending 279 | then it is printed onto the new blank line. *) 280 | if window.can_scroll = Scroll_disabled then 281 | window 282 | else 283 | let blank_line = blank_line window in 284 | let scrolled_window = { window with 285 | lines = Deque.enqueue_front (Deque.dequeue_back window.lines) blank_line; 286 | cursor = bottom_left window; 287 | pending = Nothing_pending; 288 | scroll_count = window.scroll_count + 1 ; 289 | } in 290 | let printed_window = 291 | match window.pending with 292 | | Nothing_pending -> scrolled_window 293 | | Scroll_pending text -> print scrolled_window text in 294 | let more_window = 295 | match printed_window.can_more with 296 | | More_disabled -> printed_window 297 | | More_enabled -> 298 | let (Character_height h) = printed_window.height in 299 | { printed_window with 300 | needs_more = 301 | printed_window.pending != Nothing_pending && 302 | printed_window.scroll_count >= h - 3 } in 303 | more_window 304 | 305 | (* Sometimes it is convenient to simply say "scroll the whole thing" 306 | and don't prompt for MORE. *) 307 | let rec fully_scroll window = 308 | if window.pending = Nothing_pending then 309 | { window with scroll_count = 0; needs_more = false } 310 | else 311 | fully_scroll (scroll window) 312 | 313 | let more window = 314 | if window.can_more = More_disabled then 315 | window 316 | else 317 | let blank_line = blank_line window in 318 | let more_line = replace_at blank_line 0 "[MORE]" in 319 | set_line window more_line (bottom_row window) 320 | 321 | let clear_more window = 322 | { window with scroll_count = 0; needs_more = false } 323 | 324 | (* Produces a deque of the merged window lines *) 325 | let merge w1 w2 = 326 | Deque.merge w1.lines w2.lines 327 | 328 | let cursor window = 329 | window.cursor 330 | 331 | let height window = 332 | window.height 333 | 334 | let set_lines window new_lines = 335 | { window with 336 | lines = new_lines; 337 | height = Character_height (Deque.length new_lines) } 338 | 339 | let has_pending window = 340 | window.pending != Nothing_pending 341 | 342 | let needs_more window = 343 | window.needs_more 344 | 345 | let set_can_wrap window can_wrap = 346 | { window with can_wrap } 347 | 348 | let cursor_in_bounds window cursor = 349 | let (Character_height h) = window.height in 350 | let Cursor (_, (Character_y y)) = cursor in 351 | y <= h 352 | -------------------------------------------------------------------------------- /lib/iff.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | 3 | type iff_contents = 4 | | Header of string 5 | | SubHeader of string 6 | | Length of int option 7 | | RemainingBytes of string option 8 | | ByteString of (string option) * int 9 | | Integer32 of int option 10 | | Integer24 of int option 11 | | Integer16 of int option 12 | | Integer8 of int option 13 | | Integer4 of int option 14 | | Bit of int * (bool option) 15 | | BitField of iff_contents list 16 | | Record of iff_contents list 17 | | Assign of string * iff_contents 18 | | Lookup of string 19 | | SizedList of iff_contents * (iff_contents list) 20 | | UnsizedList of iff_contents list 21 | | UnorderedList of iff_contents list 22 | 23 | exception BadFileFormat 24 | (* TODO: Better error handling *) 25 | 26 | 27 | 28 | let read_iff_file filename root_form = 29 | 30 | let rec remove_assign form = 31 | match form with 32 | | Assign (_, f) -> remove_assign f 33 | | BitField contents -> BitField (List.map remove_assign contents) 34 | | Record contents -> Record (List.map remove_assign contents) 35 | | SizedList (n, contents) -> SizedList (n, List.map remove_assign contents) 36 | | UnsizedList contents -> UnsizedList (List.map remove_assign contents) 37 | | UnorderedList contents -> UnorderedList (List.map remove_assign contents) 38 | | _ -> form in 39 | 40 | let file = get_file filename in 41 | 42 | let rec read_form offset form end_position context = 43 | let rec resolve_lookup name forms = 44 | (* Does not recurse into records. It could. *) 45 | match forms with 46 | | [] -> None 47 | | (Assign (n, v)) :: tail -> 48 | if n = name then Some v 49 | else resolve_lookup name tail 50 | | (BitField bitfields) :: tail -> 51 | (match resolve_lookup name bitfields with 52 | | None -> resolve_lookup name tail 53 | | result -> result) 54 | | _ :: tail -> resolve_lookup name tail in 55 | 56 | let read_string_from_file offset length = 57 | if offset + length > end_position then raise BadFileFormat 58 | else String.sub file offset length in 59 | 60 | let read_int8_from_file offset = 61 | if offset >= end_position then raise BadFileFormat 62 | else int_of_char file.[offset] in 63 | 64 | let read_int32_from_file offset = 65 | if offset + 4 > end_position then 66 | raise BadFileFormat 67 | else 68 | let b3 = read_int8_from_file offset in 69 | let b2 = read_int8_from_file (offset + 1) in 70 | let b1 = read_int8_from_file (offset + 2) in 71 | let b0 = read_int8_from_file (offset + 3) in 72 | b0 + 256 * b1 + 256 * 256 * b2 + 256 * 256 * 256 * b3 in 73 | 74 | let peek_chunk offset = 75 | (read_string_from_file offset 4, read_int32_from_file (offset + 4)) in 76 | 77 | let rec form_to_integer form = 78 | match form with 79 | | Length (Some n) -> n 80 | | Integer32 (Some n) -> n 81 | | Integer24 (Some n) -> n 82 | | Integer16 (Some n) -> n 83 | | Integer8 (Some n) -> n 84 | | Integer4 (Some n) -> n 85 | | Assign (_, f) -> form_to_integer f 86 | | Lookup s -> failwith "TODO: Lookup not implemented" 87 | | _ -> failwith "form does not have value" in 88 | 89 | let read_header id = 90 | let header = read_string_from_file offset 4 in 91 | if header = id then (Header id, offset + 4) 92 | else raise BadFileFormat in 93 | 94 | let read_subheader id = 95 | let header = read_string_from_file offset 4 in 96 | if header = id then (SubHeader id, offset + 4) 97 | else raise BadFileFormat in 98 | 99 | let read_length () = 100 | let length = read_int32_from_file offset in 101 | (Length (Some length), offset + 4) in 102 | 103 | let read_remaining_bytes () = 104 | let bytes = read_string_from_file offset (end_position - offset) in 105 | (RemainingBytes (Some bytes), end_position) in 106 | 107 | let read_byte_string length = 108 | let bytes = read_string_from_file offset length in 109 | (ByteString ((Some bytes), length), offset + length) in 110 | 111 | let read_int32 () = 112 | let n = read_int32_from_file offset in 113 | (Integer32 (Some n), offset + 4) in 114 | 115 | let read_int24 () = 116 | let b2 = read_int8_from_file offset in 117 | let b1 = read_int8_from_file (offset + 1) in 118 | let b0 = read_int8_from_file (offset + 2) in 119 | (Integer24 (Some (b0 + (256 * b1) + (256 * 256 * b2))), offset + 3) in 120 | 121 | let read_int16 () = 122 | let b1 = read_int8_from_file offset in 123 | let b0 = read_int8_from_file (offset + 1) in 124 | (Integer16 (Some (b0 + (256 * b1))), offset + 2) in 125 | 126 | let read_int8 () = 127 | let b0 = read_int8_from_file offset in 128 | (Integer8 (Some b0), offset + 1) in 129 | 130 | let read_record forms = 131 | let (new_end_position, skip_byte) = 132 | match forms with 133 | | (Header _) :: (Length _) :: tail -> 134 | let (_, length) = peek_chunk offset in 135 | (offset + 8 + length, length mod 2 != 0) 136 | | _ -> (end_position, false) in 137 | let process acc form = 138 | let (acc_context, current_offset, acc_results) = acc in 139 | let (new_result, new_offset) = read_form current_offset form new_end_position acc_context in 140 | (new_result :: acc_context, new_offset, new_result :: acc_results) in 141 | let (_, new_offset, results) = List.fold_left process (context, offset, []) forms in 142 | (* If a record has an odd length then there will always be 143 | an extra 0 byte unaccounted for at the end. Skip it. *) 144 | let adjusted = if skip_byte then new_offset + 1 else new_offset in 145 | (Record (List.rev results), adjusted) in 146 | 147 | let read_bitfield fields = 148 | let byte = read_int8_from_file offset in 149 | let fetch_bit n = 150 | (byte land (1 lsl n)) lsr n = 1 in 151 | let rec process_field field = 152 | match field with 153 | | Bit (n, _) -> Bit (n, Some (fetch_bit n)) 154 | | Integer4 _ -> Integer4 (Some (byte land 0xF) ) 155 | | Assign (name, f) -> Assign (name, process_field f) 156 | | _ -> failwith "pattern unexpected in bit field" in 157 | (BitField (List.map process_field fields), offset + 1) in 158 | 159 | let read_unsized_list forms = 160 | match forms with 161 | | [ form ] -> 162 | let rec aux acc current_offset = 163 | if current_offset >= end_position then (acc, current_offset) 164 | else 165 | let (new_form, new_offset) = read_form current_offset form end_position context in 166 | aux (new_form :: acc) new_offset in 167 | let (new_forms, new_offset) = aux [] offset in 168 | (UnsizedList (List.rev new_forms), new_offset) 169 | | _ -> failwith "unexpected pattern in unsized list" in 170 | 171 | let read_sized_list size forms = 172 | let (s, size_offset) = read_form offset size end_position context in 173 | let n = form_to_integer s in 174 | match forms with 175 | | [form] -> 176 | let rec aux acc i current_offset = 177 | if i = 0 then (acc, current_offset) 178 | else 179 | let (new_form, new_offset) = read_form current_offset form end_position context in 180 | aux (new_form :: acc) (i - 1) new_offset in 181 | let (new_forms, new_offset) = aux [] n offset in 182 | (SizedList (s, List.rev new_forms), new_offset) 183 | | _ -> failwith "unexpected pattern in sized list" in 184 | 185 | let read_unordered_list forms = 186 | (* We have a collection of expected chunks; we need to skip 187 | unexpected chunks. *) 188 | let rec aux acc current_offset = 189 | if current_offset >= end_position then (acc, current_offset) 190 | else 191 | let (header, length) = peek_chunk current_offset in 192 | let predicate form = 193 | match form with 194 | | Record ((Header id) :: tail) -> header = id 195 | | _ -> false in 196 | match first_match forms predicate with 197 | | None -> 198 | let new_offset = current_offset + 8 + length + (if length mod 2 = 0 then 0 else 1) in 199 | let new_form = Record [ Header header; Length (Some length); RemainingBytes None] in 200 | aux (new_form :: acc) new_offset 201 | | Some form -> 202 | let (new_form, new_offset) = read_form current_offset form end_position context in 203 | aux (new_form :: acc) new_offset in 204 | let (new_forms, new_offset) = aux [] offset in 205 | (UnorderedList (List.rev new_forms), new_offset) in 206 | 207 | match form with 208 | | Header id -> read_header id 209 | | Length _ -> read_length () 210 | | Bit _ -> failwith "Bit only expected inside bitfield" 211 | | Integer4 _ -> failwith "Integer4 only expected inside bitfield" 212 | | SubHeader id -> read_subheader id 213 | | RemainingBytes _ -> read_remaining_bytes () 214 | | ByteString (_, length) -> read_byte_string length 215 | | Integer32 _ -> read_int32 () 216 | | Integer24 _ -> read_int24 () 217 | | Integer16 _ -> read_int16 () 218 | | Integer8 _ -> read_int8 () 219 | | BitField fields -> read_bitfield fields 220 | | Record forms -> read_record forms 221 | | UnsizedList forms -> read_unsized_list forms 222 | | Assign (name, f) -> 223 | let (new_form, new_offset) = read_form offset f end_position context in 224 | (Assign (name, new_form), new_offset) 225 | | Lookup name -> 226 | (match resolve_lookup name context with 227 | | Some f -> (f, offset) 228 | | None -> failwith "Could not resolve lookup") 229 | | SizedList (size, forms) -> read_sized_list size forms 230 | | UnorderedList forms -> read_unordered_list forms in 231 | (* end of read_form *) 232 | let (form, _) = read_form 0 root_form (String.length file) [] in 233 | remove_assign form 234 | (* end of read_iff_file *) 235 | 236 | let write_iff_file filename root_form = 237 | let rec write_form form = 238 | let write_int32_to_file n = 239 | let b0 = string_of_char (char_of_int (n land 0xff)) in 240 | let b1 = string_of_char (char_of_int ((n asr 8 ) land 0xff)) in 241 | let b2 = string_of_char (char_of_int ((n asr 16) land 0xff)) in 242 | let b3 = string_of_char (char_of_int ((n asr 24) land 0xff)) in 243 | b3 ^ b2 ^ b1 ^ b0 in 244 | 245 | let write_int24_to_file n = 246 | let b0 = string_of_char (char_of_int (n land 0xff)) in 247 | let b1 = string_of_char (char_of_int ((n asr 8 ) land 0xff)) in 248 | let b2 = string_of_char (char_of_int ((n asr 16) land 0xff)) in 249 | b2 ^ b1 ^ b0 in 250 | 251 | let write_int16_to_file n = 252 | let b0 = string_of_char (char_of_int (n land 0xff)) in 253 | let b1 = string_of_char (char_of_int ((n asr 8 ) land 0xff)) in 254 | b1 ^ b0 in 255 | 256 | let write_int8_to_file n = 257 | string_of_char (char_of_int (n land 0xff)) in 258 | 259 | let write_bitfield fields = 260 | let rec process_field field = 261 | match field with 262 | | Integer4 (Some n) -> n land 0xf 263 | | Bit (n, (Some flag)) -> if flag then 1 lsl n else 0 264 | | Assign (_, named_field) -> process_field named_field 265 | | _ -> failwith "unexpected form in bitfield" in 266 | let folder b field = 267 | b lor (process_field field) in 268 | let v = List.fold_left folder 0 fields in 269 | string_of_char (char_of_int v) in 270 | 271 | let write_many s form = 272 | s ^ (write_form form) in 273 | 274 | let write_record forms = 275 | match forms with 276 | | (Header header) :: (Length _) :: tail -> 277 | let body = List.fold_left write_many "" tail in 278 | let length = String.length body in 279 | let chunk = header ^ (write_int32_to_file length) ^ body in 280 | let adjusted = if length mod 2 = 0 then chunk else chunk ^ "\000" in 281 | adjusted 282 | | _ -> List.fold_left write_many "" forms in 283 | 284 | match form with 285 | | Header header -> header 286 | | SubHeader subheader -> subheader 287 | | Length (Some length) -> write_int32_to_file length 288 | | RemainingBytes (Some bytes) -> bytes 289 | | ByteString ((Some bytes), _) -> bytes 290 | | Integer32 (Some n) -> write_int32_to_file n 291 | | Integer24 (Some n) -> write_int24_to_file n 292 | | Integer16 (Some n) -> write_int16_to_file n 293 | | Integer8 (Some n) -> write_int8_to_file n 294 | | Integer4 _ -> failwith "expected Integer4 inside bitfield" 295 | | Bit _ -> failwith "expected Bit inside bitfield" 296 | | BitField fields -> write_bitfield fields 297 | | Assign (_, named_form) -> write_form named_form 298 | | SizedList (_, forms) -> List.fold_left write_many "" forms 299 | | UnsizedList forms -> List.fold_left write_many "" forms 300 | | UnorderedList forms -> List.fold_left write_many "" forms 301 | | Record forms -> write_record forms 302 | | _ -> failwith "unexpected form in write_form" in 303 | (* end of write_form *) 304 | let text = write_form root_form in 305 | write_file filename text 306 | (* end of write_iff_file *) 307 | 308 | let rec find_record chunks target = 309 | match chunks with 310 | | [] -> None 311 | | (Record (Header header :: _) as record) :: tail -> 312 | if header = target then Some record 313 | else find_record tail target 314 | | _ :: tail -> find_record tail target 315 | -------------------------------------------------------------------------------- /lib/object.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | let invalid_data = Property_data 0 5 | let invalid_object = Object 0 6 | let invalid_property = Property 0 7 | 8 | (* The object table is laid out as follows: 9 | 10 | * The base of the object table is in the header. 11 | * The object table begins with a block of 31 or 63 default property values. 12 | * Following the default property values is the object tree. 13 | * Each entry in the tree is of the same size, and is laid out as follows: 14 | * 32 or 48 bits of attribute flags 15 | * the parent, sibling and child object numbers 16 | * the address of an additional table of variable-sized properties. 17 | * object numbers are one-based, so zero is used as the invalid object. 18 | *) 19 | 20 | let default_property_table_size story = 21 | if Story.v3_or_lower (Story.version story) then 31 else 63 22 | 23 | let default_property_table_entry_size = 2 24 | 25 | let default_property_table_base story = 26 | let (Object_base base)= Story.object_table_base story in 27 | Property_defaults_table base 28 | 29 | let default_property_value story (Property n) = 30 | if n < 1 || n > (default_property_table_size story) then 31 | failwith "invalid index into default property table" 32 | else 33 | let (Property_defaults_table base) = default_property_table_base story in 34 | let addr = Word_address ((base + (n - 1) * default_property_table_entry_size)) in 35 | Story.read_word story addr 36 | 37 | (* A debugging method for looking at the default property table *) 38 | let display_default_property_table story = 39 | let to_string i = 40 | let value = default_property_value story (Property i) in 41 | Printf.sprintf "%02x: %04x\n" i value in 42 | accumulate_strings_loop to_string 1 ((default_property_table_size story) + 1) 43 | 44 | let tree_base story = 45 | let (Object_base base) = Story.object_table_base story in 46 | let table_size = default_property_table_size story in 47 | Object_tree_base (base + default_property_table_entry_size * table_size) 48 | 49 | let entry_size story = 50 | if Story.v3_or_lower (Story.version story) then 9 else 14 51 | 52 | let address story (Object obj) = 53 | let (Object_tree_base tree_base) = tree_base story in 54 | let entry_size = entry_size story in 55 | Object_address (tree_base + (obj - 1) * entry_size) 56 | 57 | let attributes_word_1 story obj = 58 | let (Object_address addr) = address story obj in 59 | Story.read_word story (Word_address addr) 60 | 61 | let attributes_word_2 story obj = 62 | let attributes2_offset = 2 in 63 | let (Object_address addr) = address story obj in 64 | Story.read_word story (Word_address(addr + attributes2_offset)) 65 | 66 | let attributes_word_3 story obj = 67 | if Story.v3_or_lower (Story.version story) then 68 | 0 69 | else 70 | let attributes3_offset = 3 in 71 | let (Object_address addr) = address story obj in 72 | Story.read_word story (Word_address (addr + attributes3_offset)) 73 | 74 | let attribute_count story = 75 | if Story.v3_or_lower (Story.version story) then 32 else 48 76 | 77 | let attribute_address story obj (Attribute attribute) = 78 | if attribute < 0 || attribute >= (attribute_count story) then 79 | failwith "bad attribute" 80 | else 81 | let offset = attribute / 8 in 82 | let (Object_address obj_addr) = address story obj in 83 | let bit = Bit_number (7 - (attribute mod 8)) in 84 | Attribute_address ((Byte_address (obj_addr + offset)), bit) 85 | 86 | let attribute story obj attribute = 87 | let (Attribute_address (address, bit)) = attribute_address story obj attribute in 88 | Story.read_bit story address bit 89 | 90 | let set_attribute story obj attribute = 91 | let (Attribute_address (address, bit)) = attribute_address story obj attribute in 92 | Story.write_set_bit story address bit 93 | 94 | let clear_attribute story obj attribute = 95 | let (Attribute_address (address, bit)) = attribute_address story obj attribute in 96 | Story.write_clear_bit story address bit 97 | 98 | let parent story obj = 99 | let (Object_address addr) = address story obj in 100 | if Story.v3_or_lower (Story.version story) then 101 | Object (Story.read_byte story (Byte_address (addr + 4))) 102 | else 103 | Object (Story.read_word story (Word_address (addr + 6))) 104 | 105 | let set_parent story obj (Object new_parent) = 106 | let (Object_address addr) = address story obj in 107 | if Story.v3_or_lower (Story.version story) then 108 | Story.write_byte story (Byte_address (addr + 4)) new_parent 109 | else 110 | Story.write_word story (Word_address (addr + 6)) new_parent 111 | 112 | let sibling story obj = 113 | let (Object_address addr) = address story obj in 114 | if Story.v3_or_lower (Story.version story) then 115 | Object (Story.read_byte story (Byte_address (addr + 5))) 116 | else 117 | Object (Story.read_word story (Word_address (addr + 8))) 118 | 119 | let set_sibling story obj (Object new_sibling) = 120 | let (Object_address addr) = address story obj in 121 | if Story.v3_or_lower (Story.version story) then 122 | Story.write_byte story (Byte_address (addr + 5)) new_sibling 123 | else 124 | Story.write_word story (Word_address (addr + 8)) new_sibling 125 | 126 | let child story obj = 127 | let (Object_address addr) = address story obj in 128 | if Story.v3_or_lower (Story.version story) then 129 | Object (Story.read_byte story (Byte_address(addr + 6))) 130 | else 131 | Object (Story.read_word story (Word_address(addr + 10))) 132 | 133 | let set_child story obj (Object new_child) = 134 | let (Object_address addr) = address story obj in 135 | if Story.v3_or_lower (Story.version story) then 136 | Story.write_byte story (Byte_address (addr + 6)) new_child 137 | else 138 | Story.write_word story (Word_address (addr + 10)) new_child 139 | 140 | (* The last two bytes in an object description are a pointer to a 141 | block that contains additional properties. *) 142 | let property_header_address story obj = 143 | let object_property_offset = if Story.v3_or_lower (Story.version story) then 7 else 12 in 144 | let (Object_address addr) = address story obj in 145 | Property_header (Story.read_word story (Word_address (addr + object_property_offset))) 146 | 147 | (* Oddly enough, the Z machine does not ever say how big the object table is. 148 | Assume that the address of the first property block in the first object is 149 | the bottom of the object tree table. *) 150 | let count story = 151 | let (Object_tree_base table_start) = tree_base story in 152 | let (Property_header table_end) = property_header_address story (Object 1) in 153 | let entry_size = entry_size story in 154 | (table_end - table_start) / entry_size 155 | 156 | (* The property entry begins with a length-prefixed zstring *) 157 | let name story n = 158 | let (Property_header addr) = property_header_address story n in 159 | let length = Story.read_byte story (Byte_address addr) in 160 | if length = 0 then "" 161 | else Zstring.read story (Zstring (addr + 1)) 162 | 163 | let find_previous_sibling story obj = 164 | let rec aux current = 165 | let next_sibling = sibling story current in 166 | if next_sibling = obj then current 167 | else aux next_sibling in 168 | let parent = parent story obj in 169 | let first_child = child story parent in 170 | aux first_child 171 | 172 | (* Takes a child object and detatches it from its parent *) 173 | 174 | let remove story obj = 175 | let original_parent = parent story obj in 176 | if original_parent = invalid_object then 177 | story (* Already detatched *) 178 | else 179 | (* First edit: if the child is the parent's first child then 180 | make the next sibling the new first child. If the child 181 | is not the first child then the previous sibling 182 | needs to point to the next sibling. *) 183 | let edit1 = ( 184 | let sibling = sibling story obj in 185 | if obj = child story original_parent then 186 | set_child story original_parent sibling 187 | else 188 | let prev_sibling = find_previous_sibling story obj in 189 | set_sibling story prev_sibling sibling) in 190 | (* Second edit: the child now has no parent. *) 191 | set_parent edit1 obj invalid_object 192 | 193 | (* Takes a child object and a parent object, and causes the child to be the 194 | first child of the parent. *) 195 | let insert story new_child new_parent = 196 | (* Detatch the new child from its old parent *) 197 | let edit1 = remove story new_child in 198 | (* Hook up the new child to its new parent *) 199 | let edit2 = set_parent edit1 new_child new_parent in 200 | (* Hook up the sibling chain *) 201 | let edit3 = set_sibling edit2 new_child (child edit2 new_parent) in 202 | (* Make the child the new first child of the parent *) 203 | set_child edit3 new_parent new_child 204 | 205 | (* Not every object has every property. An object's properties are a 206 | zero-terminated block of memory where the first byte indicates the 207 | property number and the number of bytes in the property value. 208 | This block begins after the length-prefixed object name. *) 209 | 210 | (* Takes the address of a property block -- past the string, 211 | pointing to the block header. 212 | Returns the length of the header, the length of the data, and the 213 | property number. *) 214 | 215 | let decode_property_data story (Property_address address) = 216 | let b = Story.read_byte story (Byte_address address) in 217 | if b = 0 then 218 | (0, 0, invalid_property) 219 | else if Story.v3_or_lower (Story.version story) then 220 | (* In version 3 it's easy. The number of bytes of property data 221 | is indicated by the top 3 bits; the property number is indicated 222 | by the bottom 5 bits, and the header is one byte. *) 223 | (1, (fetch_bits bit7 size3 b) + 1, Property (fetch_bits bit4 size5 b)) 224 | else 225 | (* In version 4 the property number is the bottom 6 bits. *) 226 | let prop = Property (fetch_bits bit5 size6 b) in 227 | (* If the high bit of the first byte is set then the length is 228 | indicated by the bottom six bits of the *following* byte. 229 | The following byte needs to have its high bit set as well. 230 | (See below). 231 | 232 | If the high bit is not set then the length is indicated by 233 | the sixth bit. *) 234 | if fetch_bit bit7 b then 235 | let b2 = Story.read_byte story (Byte_address (address + 1)) in 236 | let len = fetch_bits bit5 size6 b2 in 237 | (2, (if len = 0 then 64 else len), prop) 238 | else 239 | (1, (if fetch_bit bit6 b then 2 else 1), prop) 240 | 241 | (* This method produces a list of (number, data_length, data_address) tuples *) 242 | let property_addresses story obj = 243 | let rec aux acc address = 244 | let (Property_address addr) = address in 245 | let b = Story.read_byte story (Byte_address addr) in 246 | if b = 0 then 247 | acc 248 | else 249 | let (header_length, data_length, prop) = 250 | decode_property_data story address in 251 | let this_property = 252 | (prop, data_length, Property_data (addr + header_length)) in 253 | let next_addr = Property_address (addr + header_length + data_length) in 254 | aux (this_property :: acc) next_addr in 255 | let (Property_header header) = property_header_address story obj in 256 | let property_name_address = header in 257 | let property_name_word_length = Story.read_byte story (Byte_address property_name_address) in 258 | let first_property_address = 259 | Property_address (property_name_address + 1 + property_name_word_length * 2) in 260 | aux [] first_property_address 261 | 262 | (* Given the adddress of the data block, how long is it? In version 3 263 | this is easy; we just look at the previous byte. In version 4 there could 264 | be two bytes before the data, but the one immediately before the data is 265 | always the size byte. If its high bit is on then the bottom six bits are the 266 | size. If the high bit is not on then the size is determined by bit 6. *) 267 | let property_length_from_address story (Property_data address) = 268 | if address = 0 then 269 | 0 270 | else 271 | let b = Story.read_byte story (Byte_address (address - 1)) in 272 | if Story.v3_or_lower (Story.version story) then 273 | 1 + (fetch_bits bit7 size3 b) 274 | else 275 | if fetch_bit bit7 b then 276 | let len = fetch_bits bit5 size6 b in 277 | if len = 0 then 64 else len 278 | else 279 | if fetch_bit bit6 b then 2 else 1 280 | 281 | (* Given an object and property number, what is the address 282 | of the associated property block? Or zero if there is none. *) 283 | let property_address story obj prop = 284 | let rec aux addresses = 285 | match addresses with 286 | | [] -> invalid_data 287 | | (number, _, address) :: tail -> 288 | if number = prop then address 289 | else aux tail in 290 | aux (property_addresses story obj) 291 | 292 | (* Fetch the one or two byte value associated with a given property of a given object. 293 | If the object does not have that property then fetch the default property value. *) 294 | let property story obj prop = 295 | (* We simply do a linear search for the property, even though they are 296 | stored in sorted order. The blocks we are searching are first, variable 297 | size, which makes them inconvenient to binary search. And second, are 298 | small, making binary search not worth the bother. *) 299 | let rec aux addresses = 300 | match addresses with 301 | | [] -> default_property_value story prop 302 | | (number, length, (Property_data address)) :: tail -> 303 | if number = prop then ( 304 | if length = 1 then 305 | Story.read_byte story (Byte_address address) 306 | else if length = 2 then 307 | Story.read_word story (Word_address address) 308 | else 309 | let (Object n) = obj in 310 | let (Property p) = prop in 311 | failwith (Printf.sprintf "object %d property %d length %d bad property length" n p length)) 312 | else 313 | aux tail in 314 | aux (property_addresses story obj) 315 | 316 | (* Given a property number, find the first property of an object 317 | greater than it. Note that this assumes that properties are enumerated in 318 | order by property_addresses. Returns zero if there is no such property. *) 319 | let next_property story obj (Property prop) = 320 | let rec aux addrs = 321 | match addrs with 322 | | [] -> invalid_property 323 | | (Property number, _, _) :: tail -> 324 | if number > prop then Property number 325 | else aux tail in 326 | aux (property_addresses story obj) 327 | 328 | (* Writes a one or two byte property associated with a given object. *) 329 | (* The property must exist and must be one or two bytes. *) 330 | let write_property story obj prop value = 331 | let rec aux addresses = 332 | match addresses with 333 | | [] -> (invalid_data, 0) 334 | | (number, length, address) :: tail -> 335 | if number = prop then (address, length) 336 | else aux tail in 337 | let (address, length) = aux (property_addresses story obj) in 338 | if address = invalid_data then failwith "invalid property"; 339 | let (Property_data address) = address in 340 | match length with 341 | | 1 -> Story.write_byte story (Byte_address address) value 342 | | 2 -> Story.write_word story (Word_address address) value 343 | | _ -> failwith "property cannot be set" 344 | 345 | (* Debugging method for displaying the property numbers and 346 | values for a given object *) 347 | let display_properties story obj = 348 | let to_string (prop, length, address) = 349 | let (Property p) = prop in 350 | let prop_number_text = Printf.sprintf "%02x" p in 351 | let prop_value_text = 352 | if length = 1 || length = 2 then 353 | let prop_value = property story obj prop in 354 | Printf.sprintf ":%04x " prop_value 355 | else 356 | " " in 357 | prop_number_text ^ prop_value_text in 358 | let addresses = property_addresses story obj in 359 | accumulate_strings to_string addresses 360 | 361 | let display_object_table story = 362 | let count = count story in 363 | let to_string i = 364 | let current = Object i in 365 | let flags1 = attributes_word_1 story current in 366 | let flags2 = attributes_word_2 story current in 367 | let flags3 = attributes_word_3 story current in 368 | let (Object parent) = parent story current in 369 | let (Object sibling) = sibling story current in 370 | let (Object child) = child story current in 371 | let name = name story current in 372 | let object_text = 373 | Printf.sprintf "%04d: %04x%04x%04x %04x %04x %04x %s " 374 | i flags1 flags2 flags3 parent sibling child name in 375 | let properties_text = display_properties story current in 376 | object_text ^ properties_text ^ "\n" in 377 | accumulate_strings_loop to_string 1 (count + 1) 378 | 379 | (* Count down all the objects in the object table and record which ones have no parent. *) 380 | let roots story = 381 | let rec aux obj acc = 382 | let current = Object obj in 383 | if current = invalid_object then 384 | acc 385 | else if (parent story current) = invalid_object then 386 | aux (obj - 1) (current :: acc) 387 | else 388 | aux (obj - 1) acc in 389 | aux (count story) [] 390 | 391 | let display_object_tree story = 392 | let rec aux acc indent obj = 393 | if obj = invalid_object then 394 | acc 395 | else 396 | let name = name story obj in 397 | let child = child story obj in 398 | let sibling = sibling story obj in 399 | let (Object n) = obj in 400 | let object_text = 401 | Printf.sprintf "%s%04d %s\n" indent n name in 402 | let with_object = acc ^ object_text in 403 | let new_indent = " " ^ indent in 404 | let with_children = aux with_object new_indent child in 405 | aux with_children indent sibling in 406 | let to_string obj = 407 | aux "" "" obj in 408 | accumulate_strings to_string (roots story) 409 | -------------------------------------------------------------------------------- /lib/instruction.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | type opcode_form = 5 | | Long_form 6 | | Short_form 7 | | Variable_form 8 | | Extended_form 9 | 10 | type operand_count = 11 | | OP0 12 | | OP1 13 | | OP2 14 | | VAR 15 | 16 | let decode_variable n = 17 | let maximum_local = 15 in 18 | if n = 0 then Stack 19 | else if n <= maximum_local then Local_variable (Local n) 20 | else Global_variable (Global n) 21 | 22 | let encode_variable variable = 23 | match variable with 24 | | Stack -> 0 25 | | Local_variable Local n -> n 26 | | Global_variable Global n -> n 27 | 28 | (* We match Inform's convention of numbering the locals and globals from zero *) 29 | let display_variable variable = 30 | match variable with 31 | | Stack -> "sp" 32 | | Local_variable Local local -> Printf.sprintf "local%d" (local - 1) 33 | | Global_variable Global global -> Printf.sprintf "g%02x" (global - 16) 34 | 35 | type operand_type = 36 | | Large_operand 37 | | Small_operand 38 | | Variable_operand 39 | | Omitted 40 | 41 | (* The tables which follow are maps from the opcode identification number 42 | to the opcode type; the exact order matters. *) 43 | 44 | let one_operand_bytecodes = [| 45 | OP1_128; OP1_129; OP1_130; OP1_131; OP1_132; OP1_133; OP1_134; OP1_135; 46 | OP1_136; OP1_137; OP1_138; OP1_139; OP1_140; OP1_141; OP1_142; OP1_143 |] 47 | 48 | let zero_operand_bytecodes = [| 49 | OP0_176; OP0_177; OP0_178; OP0_179; OP0_180; OP0_181; OP0_182; OP0_183; 50 | OP0_184; OP0_185; OP0_186; OP0_187; OP0_188; OP0_189; OP0_190; OP0_191 |] 51 | 52 | let two_operand_bytecodes =[| 53 | ILLEGAL; OP2_1; OP2_2; OP2_3; OP2_4; OP2_5; OP2_6; OP2_7; 54 | OP2_8; OP2_9; OP2_10; OP2_11; OP2_12; OP2_13; OP2_14; OP2_15; 55 | OP2_16; OP2_17; OP2_18; OP2_19; OP2_20; OP2_21; OP2_22; OP2_23; 56 | OP2_24; OP2_25; OP2_26; OP2_27; OP2_28; ILLEGAL; ILLEGAL; ILLEGAL |] 57 | 58 | let var_operand_bytecodes = [| 59 | VAR_224; VAR_225; VAR_226; VAR_227; VAR_228; VAR_229; VAR_230; VAR_231; 60 | VAR_232; VAR_233; VAR_234; VAR_235; VAR_236; VAR_237; VAR_238; VAR_239; 61 | VAR_240; VAR_241; VAR_242; VAR_243; VAR_244; VAR_245; VAR_246; VAR_247; 62 | VAR_248; VAR_249; VAR_250; VAR_251; VAR_252; VAR_253; VAR_254; VAR_255 |] 63 | 64 | let ext_bytecodes = [| 65 | EXT_0; EXT_1; EXT_2; EXT_3; EXT_4; EXT_5; EXT_6; EXT_7; 66 | EXT_8; EXT_9; EXT_10; EXT_11; EXT_12; EXT_13; EXT_14; ILLEGAL; 67 | EXT_16; EXT_17; EXT_18; EXT_19; EXT_20; EXT_21; EXT_22; EXT_23; 68 | EXT_24; EXT_25; EXT_26; EXT_27; EXT_28; EXT_29; ILLEGAL; ILLEGAL |] 69 | 70 | type t = 71 | { 72 | opcode : bytecode; 73 | address : instruction_address; 74 | length : int; 75 | operands : operand list; 76 | store : variable_location option; 77 | branch : (bool * branch_address) option; 78 | text : string option; 79 | } 80 | 81 | let address instruction = 82 | instruction.address 83 | 84 | let length instruction = 85 | instruction.length 86 | 87 | let opcode instruction = 88 | instruction.opcode 89 | 90 | let operands instruction = 91 | instruction.operands 92 | 93 | let store instruction = 94 | instruction.store 95 | 96 | let branch instruction = 97 | instruction.branch 98 | 99 | let text instruction = 100 | instruction.text 101 | 102 | let following instruction = 103 | let (Instruction addr) = instruction.address in 104 | (Instruction (addr + instruction.length)) 105 | 106 | let jump_address instruction offset = 107 | let (Instruction addr) = instruction.address in 108 | Instruction (addr + instruction.length + offset - 2) 109 | 110 | let is_call ver opcode = 111 | match opcode with 112 | | OP1_143 (* call_1n in v5, logical not in v1-4 *) 113 | -> Story.v5_or_higher ver 114 | | VAR_224 (* call / call_vs *) 115 | | OP1_136 (* call_1s *) 116 | | OP2_26 (* call_2n *) 117 | | OP2_25 (* call_2s *) 118 | | VAR_249 (* call_vn *) 119 | | VAR_250 (* call_vn2 *) 120 | | VAR_236 (* call_vs2 *) -> true 121 | | _ -> false 122 | 123 | let call_address instr story = 124 | if is_call (Story.version story) instr.opcode then 125 | match instr.operands with 126 | | (Large packed_address) :: _ -> 127 | let packed_address = Packed_routine packed_address in 128 | let unpacked_address = Story.decode_routine_packed_address story packed_address in 129 | Some unpacked_address 130 | | _ -> None 131 | else 132 | None 133 | 134 | let has_store opcode ver = 135 | match opcode with 136 | | OP1_143 -> Story.v4_or_lower ver (* call_1n in v5, logical not in v1-4 *) 137 | | OP0_181 -> Story.v4_or_higher ver (* save branches in v3, stores in v4 *) 138 | | OP0_182 -> Story.v4_or_higher ver (* restore branches in v3, stores in v4 *) 139 | | OP0_185 -> Story.v4_or_higher ver (* pop in v4, catch in v5 *) 140 | | VAR_233 -> ver = V6 141 | | VAR_228 -> Story.v5_or_higher ver 142 | | OP2_8 | OP2_9 | OP2_15 | OP2_16 | OP2_17 | OP2_18 | OP2_19 143 | | OP2_20 | OP2_21 | OP2_22 | OP2_23 | OP2_24 | OP2_25 144 | | OP1_129 | OP1_130 | OP1_131 | OP1_132 | OP1_136 | OP1_142 145 | | VAR_224 | VAR_231 | VAR_236 | VAR_246 | VAR_247 | VAR_248 146 | | EXT_0 | EXT_1 | EXT_2 | EXT_3 | EXT_4 | EXT_9 147 | | EXT_10 | EXT_19 | EXT_29 -> true 148 | | _ -> false 149 | 150 | let continues_to_following opcode = 151 | match opcode with 152 | | OP2_28 (* throw *) 153 | | OP1_139 (* ret *) 154 | | OP1_140 (* jump *) 155 | | OP0_176 (* rtrue *) 156 | | OP0_177 (* rfalse *) 157 | | OP0_179 (* print_ret *) 158 | | OP0_183 (* restart *) 159 | | OP0_184 (* ret_popped *) 160 | | OP0_186 (* quit *) -> false 161 | | _ -> true 162 | 163 | 164 | let has_text opcode = 165 | match opcode with 166 | | OP0_178 | OP0_179 -> true 167 | | _ -> false 168 | 169 | let has_branch opcode ver = 170 | match opcode with 171 | | OP0_181 -> Story.v3_or_lower ver (* save branches in v3, stores in v4 *) 172 | | OP0_182 -> Story.v3_or_lower ver (* restore branches in v3, stores in v4 *) 173 | | OP2_1 | OP2_2 | OP2_3 | OP2_4 | OP2_5 | OP2_6 | OP2_7 | OP2_10 174 | | OP1_128 | OP1_129 | OP1_130 | OP0_189 | OP0_191 175 | | VAR_247 | VAR_255 176 | | EXT_6 | EXT_14 | EXT_24 | EXT_27 -> true 177 | | _ -> false 178 | 179 | let has_indirection instruction ver = 180 | match (instruction.opcode, ver) with 181 | | (VAR_233, V6) -> false (* pull *) 182 | | (OP2_4, _) (* dec_chk *) 183 | | (OP2_5, _) (* inc_chk *) 184 | | (OP2_13, _) (* store *) 185 | | (OP1_133, _) (* inc *) 186 | | (OP1_134, _) (* dec *) 187 | | (OP1_142, _) (* load *) 188 | | (VAR_233, _) (* pull *) 189 | -> true 190 | | _ -> false 191 | 192 | let opcode_name opcode ver = 193 | match opcode with 194 | | ILLEGAL -> "ILLEGAL" 195 | | OP2_1 -> "je" 196 | | OP2_2 -> "jl" 197 | | OP2_3 -> "jg" 198 | | OP2_4 -> "dec_chk" 199 | | OP2_5 -> "inc_chk" 200 | | OP2_6 -> "jin" 201 | | OP2_7 -> "test" 202 | | OP2_8 -> "or" 203 | | OP2_9 -> "and" 204 | | OP2_10 -> "test_attr" 205 | | OP2_11 -> "set_attr" 206 | | OP2_12 -> "clear_attr" 207 | | OP2_13 -> "store" 208 | | OP2_14 -> "insert_obj" 209 | | OP2_15 -> "loadw" 210 | | OP2_16 -> "loadb" 211 | | OP2_17 -> "get_prop" 212 | | OP2_18 -> "get_prop_addr" 213 | | OP2_19 -> "get_next_prop" 214 | | OP2_20 -> "add" 215 | | OP2_21 -> "sub" 216 | | OP2_22 -> "mul" 217 | | OP2_23 -> "div" 218 | | OP2_24 -> "mod" 219 | | OP2_25 -> "call_2s" 220 | | OP2_26 -> "call_2n" 221 | | OP2_27 -> "set_colour" 222 | | OP2_28 -> "throw" 223 | | OP1_128 -> "jz" 224 | | OP1_129 -> "get_sibling" 225 | | OP1_130 -> "get_child" 226 | | OP1_131 -> "get_parent" 227 | | OP1_132 -> "get_prop_len" 228 | | OP1_133 -> "inc" 229 | | OP1_134 -> "dec" 230 | | OP1_135 -> "print_addr" 231 | | OP1_136 -> "call_1s" 232 | | OP1_137 -> "remove_obj" 233 | | OP1_138 -> "print_obj" 234 | | OP1_139 -> "ret" 235 | | OP1_140 -> "jump" 236 | | OP1_141 -> "print_paddr" 237 | | OP1_142 -> "load" 238 | | OP1_143 -> if Story.v4_or_lower ver then "not" else "call_1n" 239 | | OP0_176 -> "rtrue" 240 | | OP0_177 -> "rfalse" 241 | | OP0_178 -> "print" 242 | | OP0_179 -> "print_ret" 243 | | OP0_180 -> "nop" 244 | | OP0_181 -> "save" 245 | | OP0_182 -> "restore" 246 | | OP0_183 -> "restart" 247 | | OP0_184 -> "ret_popped" 248 | | OP0_185 -> if Story.v4_or_lower ver then "pop" else "catch" 249 | | OP0_186 -> "quit" 250 | | OP0_187 -> "new_line" 251 | | OP0_188 -> "show_status" 252 | | OP0_189 -> "verify" 253 | | OP0_190 -> "EXTENDED" 254 | | OP0_191 -> "piracy" 255 | | VAR_224 -> if Story.v3_or_lower ver then "call" else "call_vs" 256 | | VAR_225 -> "storew" 257 | | VAR_226 -> "storeb" 258 | | VAR_227 -> "put_prop" 259 | | VAR_228 -> if Story.v4_or_lower ver then "sread" else "aread" 260 | | VAR_229 -> "print_char" 261 | | VAR_230 -> "print_num" 262 | | VAR_231 -> "random" 263 | | VAR_232 -> "push" 264 | | VAR_233 -> "pull" 265 | | VAR_234 -> "split_window" 266 | | VAR_235 -> "set_window" 267 | | VAR_236 -> "call_vs2" 268 | | VAR_237 -> "erase_window" 269 | | VAR_238 -> "erase_line" 270 | | VAR_239 -> "set_cursor" 271 | | VAR_240 -> "get_cursor" 272 | | VAR_241 -> "set_text_style" 273 | | VAR_242 -> "buffer_mode" 274 | | VAR_243 -> "output_stream" 275 | | VAR_244 -> "input_stream" 276 | | VAR_245 -> "sound_effect" 277 | | VAR_246 -> "read_char" 278 | | VAR_247 -> "scan_table" 279 | | VAR_248 -> "not" 280 | | VAR_249 -> "call_vn" 281 | | VAR_250 -> "call_vn2" 282 | | VAR_251 -> "tokenise" 283 | | VAR_252 -> "encode_text" 284 | | VAR_253 -> "copy_table" 285 | | VAR_254 -> "print_table" 286 | | VAR_255 -> "check_arg_count" 287 | | EXT_0 -> "save" 288 | | EXT_1 -> "restore" 289 | | EXT_2 -> "log_shift" 290 | | EXT_3 -> "art_shift" 291 | | EXT_4 -> "set_font" 292 | | EXT_5 -> "draw_picture" 293 | | EXT_6 -> "picture_data" 294 | | EXT_7 -> "erase_picture" 295 | | EXT_8 -> "set_margins" 296 | | EXT_9 -> "save_undo" 297 | | EXT_10 -> "restore_undo" 298 | | EXT_11 -> "print_unicode" 299 | | EXT_12 -> "check_unicode" 300 | | EXT_13 -> "set_true_colour" 301 | | EXT_14 -> "sound_data" 302 | | EXT_16 -> "move_window" 303 | | EXT_17 -> "window_size" 304 | | EXT_18 -> "window_style" 305 | | EXT_19 -> "get_wind_prop" 306 | | EXT_20 -> "scroll_window" 307 | | EXT_21 -> "pop_stack" 308 | | EXT_22 -> "read_mouse" 309 | | EXT_23 -> "mouse_window" 310 | | EXT_24 -> "push_stack" 311 | | EXT_25 -> "put_wind_prop" 312 | | EXT_26 -> "print_form" 313 | | EXT_27 -> "make_menu" 314 | | EXT_28 -> "picture_table" 315 | | EXT_29 -> "buffer_screen" 316 | 317 | let display_indirect_operand operand = 318 | match operand with 319 | | Large large -> (display_variable (decode_variable large)) ^ " " 320 | | Small small -> (display_variable (decode_variable small)) ^ " " 321 | | Variable variable -> "[" ^ (display_variable variable) ^ "] " 322 | 323 | let display_operand operand = 324 | match operand with 325 | | Large large -> Printf.sprintf "%04x " large 326 | | Small small -> Printf.sprintf "%02x " small 327 | | Variable variable -> (display_variable variable) ^ " " 328 | 329 | let display_jump instr = 330 | (* For jumps, display the absolute target rather than the relative target. *) 331 | match instr.operands with 332 | | [Large offset] -> 333 | let offset = signed_word offset in 334 | let (Instruction target) = jump_address instr offset in 335 | Printf.sprintf "%04x " target 336 | | _ -> accumulate_strings display_operand instr.operands 337 | 338 | let display_call instr story = 339 | match call_address instr story with 340 | | Some (Routine addr) -> 341 | let routine = (Printf.sprintf "%04x " addr) in 342 | let args = accumulate_strings display_operand (List.tl instr.operands) in 343 | routine ^ args 344 | | _ -> accumulate_strings display_operand instr.operands 345 | 346 | let display_indirect_operands operands = 347 | let var = display_indirect_operand (List.hd operands) in 348 | let rest = accumulate_strings display_operand (List.tl operands) in 349 | var ^ rest 350 | 351 | let display instr story = 352 | let ver = Story.version story in 353 | 354 | let display_operands () = 355 | if instr.opcode = OP1_140 then display_jump instr 356 | else if is_call ver instr.opcode then display_call instr story 357 | else if has_indirection instr ver then display_indirect_operands instr.operands 358 | else accumulate_strings display_operand instr.operands in 359 | 360 | let display_store () = 361 | match instr.store with 362 | | None -> "" 363 | | Some variable -> "->" ^ (display_variable variable) in 364 | 365 | let display_branch () = 366 | match instr.branch with 367 | | None -> "" 368 | | Some (true, Return_false) -> "?false" 369 | | Some (false, Return_false) -> "?~false" 370 | | Some (true, Return_true) -> "?true" 371 | | Some (false, Return_true) -> "?~true" 372 | | Some (true, Branch_address Instruction address) -> Printf.sprintf "?%04x" address 373 | | Some (false, Branch_address Instruction address) -> Printf.sprintf "?~%04x" address in 374 | 375 | let display_text () = 376 | match instr.text with 377 | | None -> "" 378 | | Some str -> str in 379 | 380 | let (Instruction start_addr) = instr.address in 381 | let name = opcode_name instr.opcode ver in 382 | let operands = display_operands() in 383 | let store = display_store() in 384 | let branch = display_branch() in 385 | let text = display_text() in 386 | Printf.sprintf "%04x: %s %s%s %s %s\n" 387 | start_addr name operands store branch text 388 | (* End of display_instruction *) 389 | 390 | (* Takes the address of an instruction and produces the instruction *) 391 | let decode story (Instruction address) = 392 | let addr = Byte_address address in 393 | let ver = (Story.version story) in 394 | let read_word = Story.read_word story in 395 | let read_byte = Story.read_byte story in 396 | let read_zstring = Zstring.read story in 397 | let zstring_length = Zstring.length story in 398 | 399 | (* Spec 4.3: 400 | 401 | Each instruction has a form (long, short, extended or variable) ... 402 | If the top two bits of the opcode are $$11 the form is variable; 403 | if $$10, the form is short. If the opcode is 190 ($BE in hexadecimal) 404 | and the version is 5 or later, the form is "extended". Otherwise, 405 | the form is "long". *) 406 | 407 | let decode_form address = 408 | let b = read_byte address in 409 | match fetch_bits bit7 size2 b with 410 | | 3 -> Variable_form 411 | | 2 -> if b = 190 then Extended_form else Short_form 412 | | _ -> Long_form in 413 | 414 | (* Spec: 415 | * Each instruction has ... an operand count (0OP, 1OP, 2OP or VAR). 416 | * In short form, bits 4 and 5 of the opcode byte ... If this is $11 417 | then the operand count is 0OP; otherwise, 1OP. 418 | * In long form the operand count is always 2OP. 419 | * In variable form, if bit 5 is 0 then the count is 2OP; if it is 1, 420 | then the count is VAR. 421 | * In extended form, the operand count is VAR. *) 422 | 423 | let decode_op_count address form = 424 | let b = read_byte address in 425 | match form with 426 | | Short_form -> if fetch_bits bit5 size2 b = 3 then OP0 else OP1 427 | | Long_form -> OP2 428 | | Variable_form -> if fetch_bit bit5 b then VAR else OP2 429 | | Extended_form -> VAR in 430 | 431 | (* Spec : 432 | * In short form, ... the opcode number is given in the bottom 4 bits. 433 | * In long form ... the opcode number is given in the bottom 5 bits. 434 | * In variable form, ... the opcode number is given in the bottom 5 bits. 435 | * In extended form, ... the opcode number is given in a second opcode byte. *) 436 | 437 | (* Now what the spec does not say here clearly is: we have just read 4, 5 or 438 | 8 bits, but we need to figure out which of 100+ opcodes we're talking 439 | about. The location of the bits depends on the form, but the meaning of 440 | of the bits depends on the operand count. In fact the operation count 441 | is far more relevant here. It took me some time to puzzle out this 442 | section of the spec. The spec could more clearly say: 443 | 444 | * In extended form the EXT opcode number is given in the following byte. Otherwise: 445 | * If the operand count is 0OP then the 0OP opcode number is given in 446 | the lower 4 bits. 447 | * If the operand count is 1OP then the 1OP opcode number is given in 448 | the lower 4 bits. 449 | * if the operand count is 2OP then the 2OP opcode number is given in 450 | the lower 5 bits 451 | * If the operand count is VAR then the VAR opcode number is given in 452 | the lower 5 bits 453 | *) 454 | 455 | let decode_opcode address form op_count = 456 | let b = read_byte address in 457 | match (form, op_count) with 458 | | (Extended_form, _) -> 459 | let maximum_extended = 29 in 460 | let ext = read_byte (inc_byte_addr address) in 461 | if ext > maximum_extended then ILLEGAL else ext_bytecodes.(ext) 462 | | (_, OP0) -> zero_operand_bytecodes.(fetch_bits bit3 size4 b) 463 | | (_, OP1) -> one_operand_bytecodes.(fetch_bits bit3 size4 b) 464 | | (_, OP2) -> two_operand_bytecodes.(fetch_bits bit4 size5 b) 465 | | (_, VAR) -> var_operand_bytecodes.(fetch_bits bit4 size5 b) in 466 | 467 | let get_opcode_length form = 468 | match form with 469 | | Extended_form -> 2 470 | | _ -> 1 in 471 | 472 | (* Spec: 473 | There are four 'types' of operand. These are often specified by a 474 | number stored in 2 binary digits: 475 | * $$00 Large constant (0 to 65535) 2 bytes 476 | * $$01 Small constant (0 to 255) 1 byte 477 | * $$10 Variable 1 byte 478 | * $$11 Omitted altogether 0 bytes *) 479 | 480 | let decode_types n = 481 | match n with 482 | | 0 -> Large_operand 483 | | 1 -> Small_operand 484 | | 2 -> Variable_operand 485 | | _ -> Omitted in 486 | 487 | (* Spec 4.4 488 | Next, the types of the operands are specified. 489 | * In short form, bits 4 and 5 of the opcode give the type. 490 | * In long form, bit 6 of the opcode gives the type of the first operand, 491 | bit 5 of the second. A value of 0 means a small constant and 1 means a 492 | variable. 493 | * In variable or extended forms, a byte of 4 operand types is given next. 494 | This contains 4 2-bit fields: bits 6 and 7 are the first field, bits 0 and 495 | 1 the fourth. The values are operand types as above. Once one type has 496 | been given as 'omitted', all subsequent ones must be. 497 | * In the special case of the "double variable" VAR opcodes call_vs2 and 498 | call_vn2 a second byte of types is given, containing the types for the 499 | next four operands. *) 500 | 501 | (* Once again this could be more clearly written; the spec never calls 502 | out for instance the obvious fact that 0OP codes have no operand types. 503 | The logic is: 504 | 505 | * If the count is 0OP then there are no operand types. 506 | * If the count is 1OP then bits 4 and 5 of the opcode give the type 507 | * In long form the count is 2OP; bit 6 ... *) 508 | 509 | (* We walk the byte from low bit pairs -- which correspond to later 510 | operands -- to high bit pairs, so that the resulting list has 511 | the first operands at the head and last at the tail *) 512 | let decode_variable_types type_byte = 513 | let rec aux i acc = 514 | if i > 3 then 515 | acc 516 | else 517 | let type_bits = fetch_bits (Bit_number (i * 2 + 1)) size2 type_byte in 518 | match decode_types type_bits with 519 | | Omitted -> aux (i + 1) acc 520 | | x -> aux (i + 1) (x :: acc) in 521 | aux 0 [] in 522 | 523 | let decode_operand_types address form op_count opcode = 524 | match (form, op_count, opcode) with 525 | | (_, OP0, _) -> [] 526 | | (_, OP1, _) -> 527 | let b = read_byte address in 528 | [decode_types (fetch_bits bit5 size2 b)] 529 | | (Long_form, _, _) -> 530 | let b = read_byte address in 531 | (match fetch_bits bit6 size2 b with 532 | | 0 -> [ Small_operand; Small_operand ] 533 | | 1 -> [ Small_operand; Variable_operand ] 534 | | 2 -> [ Variable_operand; Small_operand ] 535 | | _ -> [ Variable_operand; Variable_operand ]) 536 | | (Variable_form, _, VAR_236) 537 | | (Variable_form, _, VAR_250) -> 538 | let opcode_length = get_opcode_length form in 539 | let type_byte_0 = read_byte (inc_byte_addr_by address opcode_length) in 540 | let type_byte_1 = read_byte (inc_byte_addr_by address (opcode_length + 1)) in 541 | (decode_variable_types type_byte_0) @ (decode_variable_types type_byte_1) 542 | | _ -> 543 | let opcode_length = get_opcode_length form in 544 | let type_byte = read_byte (inc_byte_addr_by address opcode_length) in 545 | decode_variable_types type_byte in 546 | 547 | let get_type_length form opcode = 548 | match (form, opcode) with 549 | | (Variable_form, VAR_236) 550 | | (Variable_form, VAR_250) -> 2 551 | | (Variable_form, _) -> 1 552 | | _ -> 0 in 553 | 554 | (* The operand types are large, small or variable, being 2, 1 and 1 bytes 555 | respectively. We take the list of operand types and produce a list of 556 | operands. *) 557 | 558 | (* This method is not tail recursive but the maximum number of operands 559 | is eight, so we don't care. *) 560 | let rec decode_operands operand_address operand_types = 561 | match operand_types with 562 | | [] -> [] 563 | | Large_operand :: remaining_types -> 564 | let w = read_word (byte_addr_to_word_addr operand_address) in 565 | let tail = decode_operands (inc_byte_addr_by operand_address word_size) remaining_types in 566 | (Large w) :: tail 567 | | Small_operand :: remaining_types -> 568 | let b = read_byte operand_address in 569 | let tail = decode_operands (inc_byte_addr operand_address) remaining_types in 570 | (Small b) :: tail 571 | | Variable_operand :: remaining_types -> 572 | let b = read_byte operand_address in 573 | let v = decode_variable b in 574 | let tail = decode_operands (inc_byte_addr operand_address) remaining_types in 575 | (Variable v) :: tail 576 | | Omitted :: _ -> 577 | failwith "omitted operand type passed to decode operands" in 578 | 579 | let rec get_operand_length operand_types = 580 | match operand_types with 581 | | [] -> 0 582 | | Large_operand :: remaining_types -> word_size + (get_operand_length remaining_types) 583 | | _ :: remaining_types -> 1 + (get_operand_length remaining_types) in 584 | 585 | (* Spec 4.6: 586 | "Store" instructions return a value: e.g., mul multiplies its two 587 | operands together. Such instructions must be followed by a single byte 588 | giving the variable number of where to put the result. *) 589 | 590 | (* This is straightforward but I note something odd; the wording above 591 | implies that the instruction has ended after the operands, and that 592 | the store (and hence also branch and text) *follow* the instruction. 593 | I cannot get behind this. The store, branch and text are all part of 594 | an instruction. *) 595 | 596 | let decode_store store_address opcode ver = 597 | if has_store opcode ver then 598 | let store_byte = read_byte store_address in 599 | Some (decode_variable store_byte) 600 | else 601 | None in 602 | 603 | let get_store_length opcode ver = 604 | if has_store opcode ver then 1 else 0 in 605 | 606 | (* Spec 4.7 607 | * Instructions which test a condition are called "branch" instructions. 608 | * The branch information is stored in one or two bytes, indicating what to 609 | do with the result of the test. 610 | * If bit 7 of the first byte is 0, a branch occurs when the condition was 611 | false; if 1, then branch is on true. 612 | * If bit 6 is set, then the branch occupies 1 byte only, and the "offset" 613 | is in the range 0 to 63, given in the bottom 6 bits. 614 | * If bit 6 is clear, then the offset is a signed 14-bit number given in 615 | bits 0 to 5 of the first byte followed by all 8 of the second. 616 | * An offset of 0 means "return false from the current routine", and 1 means 617 | "return true from the current routine". 618 | * Otherwise, a branch moves execution to the instruction at address 619 | (Address after branch data) + Offset - 2. *) 620 | 621 | let decode_branch branch_code_address opcode ver = 622 | if has_branch opcode ver then 623 | let high = read_byte branch_code_address in 624 | let sense = fetch_bit bit7 high in 625 | let bottom6 = fetch_bits bit5 size6 high in 626 | let offset = 627 | if fetch_bit bit6 high then 628 | bottom6 629 | else 630 | let low = read_byte (inc_byte_addr branch_code_address) in 631 | let unsigned = 256 * bottom6 + low in 632 | if unsigned < 8192 then unsigned else unsigned - 16384 in 633 | let branch = 634 | match offset with 635 | | 0 -> (sense, Return_false) 636 | | 1 -> (sense, Return_true) 637 | | _ -> 638 | let branch_length = if fetch_bit bit6 high then 1 else 2 in 639 | let (Byte_address address_after) = inc_byte_addr_by branch_code_address branch_length in 640 | let branch_target = Instruction (address_after + offset - 2) in 641 | (sense, Branch_address branch_target) in 642 | Some branch 643 | else 644 | None in 645 | 646 | let get_branch_length branch_code_address opcode ver = 647 | if has_branch opcode ver then 648 | let b = read_byte branch_code_address in 649 | if fetch_bit bit6 b then 1 else 2 650 | else 0 in 651 | 652 | (* Spec: 653 | Two opcodes, print and print_ret, are followed by a text string. *) 654 | 655 | let decode_text text_address opcode = 656 | if has_text opcode then 657 | Some (read_zstring text_address) 658 | else 659 | None in 660 | 661 | let get_text_length text_address opcode = 662 | if has_text opcode then 663 | zstring_length text_address 664 | else 665 | 0 in 666 | 667 | (* Helper methods are done. Start decoding *) 668 | 669 | let form = decode_form addr in 670 | let op_count = decode_op_count addr form in 671 | let opcode = decode_opcode addr form op_count in 672 | let opcode_length = get_opcode_length form in 673 | let operand_types = decode_operand_types addr form op_count opcode in 674 | let type_length = get_type_length form opcode in 675 | let operand_address = inc_byte_addr_by addr (opcode_length + type_length) in 676 | let operands = decode_operands operand_address operand_types in 677 | let operand_length = get_operand_length operand_types in 678 | let store_address = inc_byte_addr_by operand_address operand_length in 679 | let store = decode_store store_address opcode ver in 680 | let store_length = get_store_length opcode ver in 681 | let branch_code_address = inc_byte_addr_by store_address store_length in 682 | let branch = decode_branch branch_code_address opcode ver in 683 | let branch_length = get_branch_length branch_code_address opcode ver in 684 | let (Byte_address ba) = branch_code_address in 685 | let text_address = Zstring (ba + branch_length) in 686 | let text = decode_text text_address opcode in 687 | let text_length = get_text_length text_address opcode in 688 | let length = 689 | opcode_length + type_length + operand_length + store_length + 690 | branch_length + text_length in 691 | let address = Instruction address in 692 | { opcode; address; length; operands; store; branch; text } 693 | -------------------------------------------------------------------------------- /lib/story.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Type 3 | 4 | (* The Z Machine divides memory into dynamic and static; dynamic is always 5 | before static memory. Static memory may not change. We therefore model 6 | memory as a dynamic block that tracks updates and a static block that 7 | never changes at all. *) 8 | 9 | type t = 10 | { 11 | dynamic_memory : Immutable_bytes.t; 12 | static_memory : string; 13 | } 14 | 15 | let make dynamic static = 16 | { 17 | dynamic_memory = Immutable_bytes.make dynamic; 18 | static_memory = static; 19 | } 20 | 21 | let read_byte story address = 22 | let dynamic_size = Immutable_bytes.size story.dynamic_memory in 23 | if is_in_range address dynamic_size then 24 | Immutable_bytes.read_byte story.dynamic_memory address 25 | else 26 | let static_addr = dec_byte_addr_by address dynamic_size in 27 | dereference_string static_addr story.static_memory 28 | 29 | let read_word story address = 30 | let high = read_byte story (address_of_high_byte address) in 31 | let low = read_byte story (address_of_low_byte address) in 32 | 256 * high + low 33 | 34 | let write_byte story address value = 35 | let dynamic_memory = Immutable_bytes.write_byte story.dynamic_memory address value in 36 | { story with dynamic_memory } 37 | 38 | let write_word story address value = 39 | let high = (value lsr 8) land 0xFF in 40 | let low = value land 0xFF in 41 | let story = write_byte story (address_of_high_byte address) high in 42 | write_byte story (address_of_low_byte address) low 43 | 44 | let original story = 45 | let original_bytes = Immutable_bytes.original story.dynamic_memory in 46 | { story with dynamic_memory = original_bytes } 47 | 48 | let read_bit story address bit = 49 | fetch_bit bit (read_byte story address) 50 | 51 | let read_word_bit story address bit = 52 | fetch_bit bit (read_word story address) 53 | 54 | let write_set_bit story address bit = 55 | let orig_byte = read_byte story address in 56 | let new_byte = set_bit bit orig_byte in 57 | write_byte story address new_byte 58 | 59 | let write_clear_bit story address bit = 60 | let orig_byte = read_byte story address in 61 | let new_byte = clear_bit bit orig_byte in 62 | write_byte story address new_byte 63 | 64 | let write_set_bit_to story address bit value = 65 | let orig_byte = read_byte story address in 66 | let new_byte = set_bit_to bit orig_byte value in 67 | write_byte story address new_byte 68 | 69 | let write_set_word_bit_to story address bit value = 70 | let orig_word = read_word story address in 71 | let new_word = set_bit_to bit orig_word value in 72 | write_word story address new_word 73 | 74 | (* Writes bytes into memory; no zstring encoding, no zero 75 | termination, no length. *) 76 | let write_string story str text = 77 | let length = String.length text in 78 | let rec aux i story = 79 | if i = length then 80 | story 81 | else 82 | let story = write_byte story (byte_of_string str i) (int_of_char text.[i]) in 83 | aux (i + 1) story in 84 | aux 0 story 85 | 86 | (* Writes a series of bytes into memory. Does not zstring encode them. 87 | Does zero-byte terminate them. *) 88 | let write_string_zero_terminate story sz text = 89 | let null_byte = 0 in 90 | let length = String.length text in 91 | let str = string_of_sz sz in 92 | let story = write_string story str text in 93 | let terminator = byte_of_string str length in 94 | write_byte story terminator null_byte 95 | 96 | (* Writes a series of bytes into memory; no zero terminator, 97 | prefixed by two bytes of length *) 98 | let write_length_word_prefixed_string story wps text = 99 | let str = string_of_wps wps in 100 | let length_addr = length_addr_of_wps wps in 101 | let story = write_string story str text in 102 | let length = String.length text in 103 | write_word story length_addr length 104 | 105 | (* Writes a series of bytes into memory; no zero terminator, 106 | prefixed by one byte of length *) 107 | let write_length_byte_prefixed_string story bps text = 108 | let str = string_of_bps bps in 109 | let length_addr = length_addr_of_bps bps in 110 | let story = write_string story str text in 111 | let length = String.length text in 112 | write_byte story length_addr length 113 | 114 | (* Debugging method for displaying a raw block of memory. *) 115 | let display_story_bytes story address length = 116 | let get_byte addr = read_byte story addr in 117 | display_bytes get_byte address length 118 | 119 | (* *) 120 | (* Header *) 121 | (* *) 122 | 123 | let header_size = 64 124 | 125 | (* Header byte 0 is the version number, from 1 to 8. *) 126 | 127 | let version_offset = Byte_address 0 128 | let version story = 129 | match read_byte story version_offset with 130 | | 1 -> V1 131 | | 2 -> V2 132 | | 3 -> V3 133 | | 4 -> V4 134 | | 5 -> V5 135 | | 6 -> V6 136 | | 7 -> V7 137 | | 8 -> V8 138 | | _ -> failwith "unknown version" 139 | 140 | (* We often need to know what version we're in, but typically the only 141 | interesting questions are "are we in v4 or better?" and "are we in v5 142 | or better?" *) 143 | 144 | let v5_or_lower v = 145 | match v with 146 | | V1 | V2 | V3 | V4 | V5 -> true 147 | | V6 | V7 | V8 -> false 148 | 149 | let v6_or_higher v = 150 | not (v5_or_lower v) 151 | 152 | let v4_or_lower v = 153 | match v with 154 | | V1 | V2 | V3 | V4 -> true 155 | | V5 | V6 | V7 | V8 -> false 156 | 157 | let v5_or_higher v = 158 | not (v4_or_lower v) 159 | 160 | let v3_or_lower v = 161 | match v with 162 | | V1 | V2 | V3 -> true 163 | | V4 | V5 | V6 | V7 | V8 -> false 164 | 165 | let v4_or_higher v = 166 | not (v3_or_lower v) 167 | 168 | let display_version v = 169 | match v with 170 | | V1 -> "1" 171 | | V2 -> "2" 172 | | V3 -> "3" 173 | | V4 -> "4" 174 | | V5 -> "5" 175 | | V6 -> "6" 176 | | V7 -> "7" 177 | | V8 -> "8" 178 | 179 | (* Header byte 1 is flags. *) 180 | 181 | let flags1_offset = Byte_address 1 182 | let flags1 story = 183 | read_byte story flags1_offset 184 | 185 | let set_flags1 story value = 186 | write_byte story flags1_offset value 187 | 188 | let flags1_bit story bit = 189 | read_bit story flags1_offset bit 190 | 191 | let set_flags1_bit_to story bit value = 192 | write_set_bit_to story flags1_offset bit value 193 | 194 | (* Bit 0 of flags1 indicates whether an interpreter has colours available. *) 195 | (* It is valid only in version 5 and up. *) 196 | (* It should be set by the interpreter on a start / restart / restore. *) 197 | 198 | let colours_supported_bit = bit0 199 | 200 | let colours_supported story = 201 | if v4_or_lower (version story) then Colours_supported false 202 | else Colours_supported (flags1_bit story colours_supported_bit) 203 | 204 | let set_colours_supported story (Colours_supported value) = 205 | if v4_or_lower (version story) then story 206 | else set_flags1_bit_to story colours_supported_bit value 207 | 208 | (* Bit 1 of flags1 indicates whether a version 3 story wants a "score" or a "time" 209 | status line. This is valid only in version 3; version 1 and 2 stories were 210 | always "score", and version 4 and above stories draw their own status lines 211 | in game logic rather than asking the interpreter to do it. *) 212 | 213 | (* This bit is not writable by the interpreter in v1 / v2 / v3. *) 214 | 215 | (* In version 6 and above this flag indicates whether the interpreter can 216 | draw pictures. It should be written on restart / restore. *) 217 | 218 | let status_line_kind_bit = bit1 219 | 220 | let status_line_kind story = 221 | match (version story, flags1_bit story status_line_kind_bit) with 222 | | (V1, _) | (V2, _) | (V3, false) -> ScoreStatus 223 | | (V3, true) -> TimeStatus 224 | | _ -> NoStatus 225 | 226 | let pictures_supported_bit = bit1 227 | 228 | let pictures_supported story = 229 | if v5_or_lower (version story) then Pictures_supported false 230 | else Pictures_supported (flags1_bit story pictures_supported_bit) 231 | 232 | let set_pictures_supported story (Pictures_supported value) = 233 | if v5_or_lower (version story) then story 234 | else set_flags1_bit_to story pictures_supported_bit value 235 | 236 | (* Bit 2 of flags1 in v1 / v2 / v3 indicates whether a story file is split across two 237 | disks. We ignore it. In v4 and above it indicates whether boldface is available. 238 | It should be written on start / restart / restore *) 239 | 240 | let boldface_supported_bit = bit2 241 | 242 | let boldface_supported story = 243 | if v3_or_lower (version story) then Boldface_supported false 244 | else Boldface_supported (flags1_bit story boldface_supported_bit) 245 | 246 | let set_boldface_supported story (Boldface_supported value) = 247 | if v3_or_lower (version story) then story 248 | else set_flags1_bit_to story boldface_supported_bit value 249 | 250 | (* Bit 3 of flags1 is the "Tandy" bit in v1/v2/v3. see Spec Appendix B for 251 | details. This bit may be set by the interpreter but need not be restored. *) 252 | 253 | (* In v4 and above it indicates whether italics are supported; this bit should 254 | be set on start / restart / restore *) 255 | 256 | let tandy_bit = bit3 257 | 258 | let tandy_mode story = 259 | if v4_or_higher (version story) then Tandy_mode_enabled false 260 | else Tandy_mode_enabled (flags1_bit story tandy_bit) 261 | 262 | let set_tandy_mode story (Tandy_mode_enabled value) = 263 | if v4_or_higher (version story) then story 264 | else set_flags1_bit_to story tandy_bit value 265 | 266 | let italics_supported_bit = bit3 267 | 268 | let italics_supported story = 269 | if v3_or_lower (version story) then Italics_supported false 270 | else Italics_supported (flags1_bit story italics_supported_bit) 271 | 272 | let set_italics_supported story (Italics_supported value) = 273 | if v3_or_lower (version story) then story 274 | else set_flags1_bit_to story italics_supported_bit value 275 | 276 | (* Bit 4 of flags1 indicates whether a v1/v2/v3 interpreter is capable of 277 | displaying a status line. Note that this is inverted in the story memory; 278 | the bit is ON if a status line is NOT available. *) 279 | 280 | (* This bit should be set by the interpreter after a start / restart / restore. *) 281 | 282 | (* In v4 and above this indicates whether a fixed pitch font is available. *) 283 | 284 | (* This bit should be set by the interpreter after a start / restart / restore. *) 285 | 286 | let status_line_supported_bit = bit4 287 | 288 | let status_line_supported story = 289 | if v4_or_higher (version story) then Status_line_supported false 290 | else Status_line_supported (not (flags1_bit story status_line_supported_bit)) 291 | 292 | let set_status_line_supported story (Status_line_supported value) = 293 | if v4_or_higher (version story) then story 294 | else set_flags1_bit_to story italics_supported_bit (not value) 295 | 296 | let fixed_pitch_supported_bit = bit4 297 | 298 | let fixed_pitch_supported story = 299 | if v3_or_lower (version story) then Fixed_pitch_supported true 300 | else Fixed_pitch_supported (flags1_bit story fixed_pitch_supported_bit) 301 | 302 | let set_fixed_pitch_supported story (Fixed_pitch_supported value) = 303 | if v3_or_lower (version story) then story 304 | else set_flags1_bit_to story fixed_pitch_supported_bit value 305 | 306 | (* Bit 5 of flags1 in v1/v2/v3 indicates whether an interpreter is capable of "splitting" 307 | the screen into multiple logical windows. (We presume that all interpreters are 308 | so capable in later versions.) *) 309 | 310 | (* This bit should be set by the interpreter after a start / restart / restore. *) 311 | 312 | (* In v6 and above this bit indicates whether sound effects are avaialable. *) 313 | 314 | (* This bit should be set by the interpreter after a start / restart / restore. *) 315 | 316 | let screen_split_supported_bit = bit5 317 | 318 | let screen_split_supported story = 319 | if v4_or_higher (version story) then Screen_split_supported true 320 | else Screen_split_supported (flags1_bit story screen_split_supported_bit) 321 | 322 | let set_screen_split_supported story (Screen_split_supported value) = 323 | if v4_or_higher (version story) then story 324 | else set_flags1_bit_to story screen_split_supported_bit value 325 | 326 | let sound_effects_supported_bit = bit5 327 | 328 | let sound_effects_supported story = 329 | if v5_or_lower (version story) then Sound_effects_supported false 330 | else Sound_effects_supported (flags1_bit story sound_effects_supported_bit) 331 | 332 | let set_sound_effects_supported story (Sound_effects_supported value) = 333 | if v5_or_lower (version story) then story 334 | else set_flags1_bit_to story sound_effects_supported_bit value 335 | 336 | (* Bit 6 of flags1 indicates whether an interpreter uses a variable-pitched 337 | typeface by default. *) 338 | 339 | (* This bit should be set by the interpreter after a start / restart / restore. *) 340 | 341 | let default_is_variable_pitch_bit = bit6 342 | 343 | let default_is_variable_pitch story = 344 | Default_is_variable_pitch (flags1_bit story default_is_variable_pitch_bit) 345 | 346 | let set_default_is_variable_pitch story (Default_is_variable_pitch value) = 347 | set_flags1_bit_to story default_is_variable_pitch_bit value 348 | 349 | (* Bit 7 of flags1 indicates whether an interpreter supports timed keyboard input. *) 350 | 351 | (* This bit should be set by the interpreter after a start / restart / restore. *) 352 | 353 | let timed_keyboard_supported_bit = bit7 354 | 355 | let timed_keyboard_supported story = 356 | Timed_keyboard_supported (flags1_bit story timed_keyboard_supported_bit) 357 | 358 | let set_timed_keyboard_supported story (Timed_keyboard_supported value) = 359 | set_flags1_bit_to story timed_keyboard_supported_bit value 360 | 361 | (* Bytes 2 and 3 of the header are by convention the release number. *) 362 | 363 | let release_number_offset = Word_address 2 364 | 365 | let release_number story = 366 | Release_number (read_word story release_number_offset) 367 | 368 | (* Bytes 4 and 5 of the header indicate the start of "high" memory. The 369 | high memory mark was useful for early interpreters; the idea was that 370 | low memory would be kept in physical memory, and high memory could be 371 | paged into physical memory as needed. This interpreter makes no use 372 | of the high memory mark. *) 373 | 374 | let high_memory_base story = 375 | let high_memory_base_offset = Word_address 4 in 376 | High_memory_base (read_word story high_memory_base_offset) 377 | 378 | (* Bytes 6 and 7 are the initial pc for the main routine. In version 6 (only) 379 | this is the (packed!) address of a routine, so the *following* byte is the first 380 | instruction. In all other versions the main routine is indicated just by 381 | its first instruction. *) 382 | 383 | let initial_program_counter story = 384 | let initial_program_counter_offset = Word_address 6 in 385 | let pc = read_word story initial_program_counter_offset in 386 | if (version story) = V6 then Instruction (pc * 4 + 1) 387 | else Instruction pc 388 | 389 | (* Spec: The dictionary table is held in static memory and its byte address 390 | is stored in the word at $08 in the header. *) 391 | 392 | let dictionary_base story = 393 | let dictionary_base_offset = Word_address 8 in 394 | Dictionary_base (read_word story dictionary_base_offset) 395 | 396 | (* The object table address is stored at byte 10 *) 397 | 398 | let object_table_base story = 399 | let object_table_base_offset = Word_address 10 in 400 | Object_base (read_word story object_table_base_offset) 401 | 402 | let global_variables_table_base story = 403 | let global_variables_table_base_offset = Word_address 12 in 404 | Global_table_base (read_word story global_variables_table_base_offset) 405 | 406 | let static_memory_base_offset = Word_address 14 407 | let static_memory_base story = 408 | Static_memory_base (read_word story static_memory_base_offset) 409 | 410 | let flags2_offset = Word_address 16 411 | 412 | let flags2 story = 413 | read_word story flags2_offset 414 | 415 | let set_flags2 story value = 416 | write_word story flags2_offset value 417 | 418 | let flags2_bit story bit = 419 | read_word_bit story flags2_offset bit 420 | 421 | let set_flags2_bit_to story bit value = 422 | write_set_word_bit_to story flags2_offset bit value 423 | 424 | let transcript_bit = bit0 425 | let transcript_enabled story = 426 | Transcript_enabled (flags2_bit story transcript_bit) 427 | 428 | let set_transcript_enabled story (Transcript_enabled value) = 429 | set_flags2_bit_to story transcript_bit value 430 | 431 | let force_fixed_pitch_bit = bit1 432 | let force_fixed_pitch story = 433 | Force_fixed_pitch (flags2_bit story force_fixed_pitch_bit) 434 | 435 | let draw_status_requested_bit = bit2 436 | let draw_status_requested story = 437 | Draw_status_requested (flags2_bit story draw_status_requested_bit) 438 | 439 | let set_draw_status_requested story (Draw_status_requested value) = 440 | set_flags2_bit_to story draw_status_requested_bit value 441 | 442 | let pictures_requested_bit = bit3 443 | let pictures_requested story = 444 | Pictures_requested (flags2_bit story pictures_requested_bit) 445 | 446 | let set_pictures_requested story (Pictures_requested value) = 447 | set_flags2_bit_to story pictures_requested_bit value 448 | 449 | let undo_requested_bit = bit4 450 | let undo_requested story = 451 | Undo_requested (flags2_bit story undo_requested_bit) 452 | 453 | let set_undo_requested story (Undo_requested value) = 454 | set_flags2_bit_to story undo_requested_bit value 455 | 456 | let mouse_requested_bit = bit5 457 | let mouse_requested story = 458 | Mouse_requested (flags2_bit story mouse_requested_bit) 459 | 460 | let set_mouse_requested story (Mouse_requested value) = 461 | set_flags2_bit_to story mouse_requested_bit value 462 | 463 | let colours_requested story = 464 | let colours_requested_bit = bit6 in 465 | Colours_requested (flags2_bit story colours_requested_bit) 466 | 467 | let sound_requested_bit = bit7 468 | let sound_requested story = 469 | Sound_requested (flags2_bit story sound_requested_bit) 470 | 471 | let set_sound_requested story (Sound_requested value) = 472 | set_flags2_bit_to story sound_requested_bit value 473 | 474 | let menus_requested_bit = bit8 475 | let menus_requested story = 476 | Menus_requested (flags2_bit story menus_requested_bit) 477 | 478 | let set_menus_requested story (Menus_requested value) = 479 | set_flags2_bit_to story menus_requested_bit value 480 | 481 | let serial_number story = 482 | let start_offset = 18 in 483 | let end_offset = 24 in 484 | let string_of_byte addr = 485 | let b = read_byte story (Byte_address addr) in 486 | string_of_char (char_of_int b) in 487 | Serial_number (accumulate_strings_loop string_of_byte start_offset end_offset) 488 | 489 | let abbreviations_table_base story = 490 | let abbreviations_table_base_offset = Word_address 24 in 491 | Abbreviation_table_base (read_word story abbreviations_table_base_offset) 492 | 493 | (* Spec: The file length stored at $1a is actually divided by a constant, 494 | depending on the Version, to make it fit into a header word. This constant 495 | is 2 for Versions 1 to 3, 4 for Versions 4 to 5 or 8 for Versions 6 and later. *) 496 | 497 | let file_size story = 498 | let file_size_offset = Word_address 26 in 499 | let s = read_word story file_size_offset in 500 | let m = match (version story) with 501 | | V1 | V2 | V3 -> 2 502 | | V4 | V5 -> 4 503 | | _ -> 8 in 504 | File_size (s * m) 505 | 506 | let header_checksum story = 507 | let checksum_offset = Word_address 28 in 508 | Checksum (read_word story checksum_offset) 509 | 510 | (* The checksum is simply the bottom two bytes of the sum of all the 511 | bytes in the original story file, not counting the header. *) 512 | let compute_checksum story = 513 | let orig = original story in 514 | let (File_size size) = file_size story in 515 | let size = Byte_address size in 516 | let rec aux acc addr = 517 | if addr = size then 518 | acc 519 | else 520 | let byte = read_byte orig addr in 521 | let sum = unsigned_word (acc + byte) in 522 | aux sum (inc_byte_addr addr) in 523 | Checksum (aux 0 (Byte_address header_size)) 524 | 525 | let verify_checksum story = 526 | let h = header_checksum story in 527 | let c = compute_checksum story in 528 | h = c 529 | 530 | let interpreter_number_offset = Byte_address 30 531 | let interpreter_number story = 532 | Interpreter_number (read_byte story interpreter_number_offset) 533 | 534 | let set_interpreter_number story (Interpreter_number number) = 535 | write_byte story interpreter_number_offset number 536 | 537 | let dec_system_20 = Interpreter_number 1 538 | let apple_iie = Interpreter_number 2 539 | let macintosh = Interpreter_number 3 540 | let amiga = Interpreter_number 4 541 | let atari_st = Interpreter_number 5 542 | let ibm_pc = Interpreter_number 6 543 | let commodore_128 = Interpreter_number 7 544 | let commodore_64 = Interpreter_number 8 545 | let apple_iic = Interpreter_number 9 546 | let apple_iigs = Interpreter_number 10 547 | let tandy_color = Interpreter_number 11 548 | 549 | let interpreter_version_offset = Byte_address 31 550 | let interpreter_version story = 551 | Interpreter_version (read_byte story interpreter_version_offset) 552 | 553 | let set_interpreter_version story (Interpreter_version version) = 554 | write_byte story interpreter_version_offset version 555 | 556 | let screen_height_offset = Byte_address 32 557 | let screen_height story = 558 | Character_height (read_byte story screen_height_offset) 559 | 560 | let set_screen_height story (Character_height height) = 561 | write_byte story screen_height_offset height 562 | 563 | let screen_width_offset = Byte_address 33 564 | let screen_width story = 565 | Character_width (read_byte story screen_width_offset) 566 | 567 | let set_screen_width story (Character_width width) = 568 | write_byte story screen_width_offset width 569 | 570 | let screen_height_units_offset = Word_address 34 571 | let screen_height_units story = 572 | Pixel_height (read_word story screen_height_units_offset) 573 | 574 | let set_screen_height_units story (Pixel_height height) = 575 | write_word story screen_height_units_offset height 576 | 577 | let screen_width_units_offset = Word_address 36 578 | let screen_width_units story = 579 | Pixel_width (read_word story screen_width_units_offset) 580 | 581 | let set_screen_width_units story (Pixel_width width) = 582 | write_word story screen_width_units_offset width 583 | 584 | (* The font height and width header bytes are swapped in version 6. *) 585 | 586 | let font_height_offset story = 587 | if (version story) = V6 then (Byte_address 38) else (Byte_address 39) 588 | 589 | let font_height story = 590 | Pixel_height (read_byte story (font_height_offset story)) 591 | 592 | let set_font_height story (Pixel_height height) = 593 | write_byte story (font_height_offset story) height 594 | 595 | let font_width_offset story = 596 | if (version story) = V6 then (Byte_address 39) else (Byte_address 38) 597 | 598 | let font_width story = 599 | Pixel_width (read_byte story (font_width_offset story)) 600 | 601 | let set_font_width story (Pixel_width width) = 602 | write_byte story (font_width_offset story) width 603 | 604 | let routine_offset story = 605 | let routine_offset_offset = Word_address 40 in 606 | 8 * (read_word story routine_offset_offset) 607 | 608 | let string_offset story = 609 | let string_offset_offset = Word_address 42 in 610 | 8 * (read_word story string_offset_offset) 611 | 612 | let default_background_colour_offset = Byte_address 44 613 | let default_background_colour story = 614 | Colour (read_byte story default_background_colour_offset) 615 | 616 | let set_default_background_colour story (Colour colour) = 617 | write_byte story default_background_colour_offset colour 618 | 619 | let default_foreground_colour_offset = Byte_address 45 620 | let default_foreground_colour story = 621 | Colour (read_byte story default_foreground_colour_offset) 622 | 623 | let set_default_foreground_colour story (Colour colour) = 624 | write_byte story default_foreground_colour_offset colour 625 | 626 | let terminating_characters_offset = Word_address 46 627 | let terminating_characters_base story = 628 | Terminating_characters_base (read_word story terminating_characters_offset) 629 | 630 | let text_width_offset = Word_address 48 631 | let text_width story = 632 | Pixel_width (read_word story text_width_offset) 633 | 634 | let set_text_width story (Pixel_width width) = 635 | write_word story text_width_offset width 636 | 637 | let standard_major_offset = Byte_address 50 638 | let standard_minor_offset = Byte_address 51 639 | let standard_revision story = 640 | Revision ( 641 | (read_byte story standard_major_offset), 642 | (read_byte story standard_minor_offset)) 643 | 644 | let set_standard_revision story (Revision (major, minor)) = 645 | let story = write_byte story standard_major_offset major in 646 | write_byte story standard_minor_offset minor 647 | 648 | let alphabet_table story = 649 | let alphabet_table_offset = Word_address 52 in 650 | Alphabet_table (read_word story alphabet_table_offset) 651 | 652 | let header_extension story = 653 | let header_extension_offset = Word_address 54 in 654 | Word_address (read_word story header_extension_offset) 655 | 656 | let header_extension_word story offset = 657 | let base = header_extension story in 658 | if base = Word_address 0 then 0 659 | else read_word story (inc_word_addr_by base offset) 660 | 661 | let set_header_extension_word story offset value = 662 | let base = header_extension story in 663 | if base = Word_address 0 then story 664 | else write_word story (inc_word_addr_by base offset) value 665 | 666 | let mouse_x_offset = 1 667 | let mouse_x story = 668 | Pixel_x (header_extension_word story mouse_x_offset) 669 | 670 | let set_mouse_x story (Pixel_x x)= 671 | set_header_extension_word story x mouse_x_offset 672 | 673 | let mouse_y_offset = 2 674 | let mouse_y story = 675 | Pixel_y (header_extension_word story mouse_y_offset) 676 | 677 | let set_mouse_y story (Pixel_y y)= 678 | set_header_extension_word story y mouse_y_offset 679 | 680 | let display_header story = 681 | let (Release_number release_number) = release_number story in 682 | let (Serial_number serial_number) = serial_number story in 683 | let (Checksum checksum) = header_checksum story in 684 | let (File_size file_size) = file_size story in 685 | let (Abbreviation_table_base abbrev_table_base) = abbreviations_table_base story in 686 | let (Object_base object_table_base) = object_table_base story in 687 | let (Global_table_base global_table_base) = global_variables_table_base story in 688 | let (Static_memory_base static_memory_base) = static_memory_base story in 689 | let (Dictionary_base dictionary_base) = dictionary_base story in 690 | let (High_memory_base high_memory_base) = high_memory_base story in 691 | let (Instruction ipc) = initial_program_counter story in 692 | Printf.sprintf "Version : %s\n" (display_version (version story)) ^ 693 | Printf.sprintf "Release number : %d\n" release_number ^ 694 | Printf.sprintf "Serial number : %s\n" serial_number ^ 695 | Printf.sprintf "Checksum : %04x\n" checksum ^ 696 | Printf.sprintf "File size : %d\n" file_size ^ 697 | Printf.sprintf "Abbreviations table base : %04x\n" abbrev_table_base ^ 698 | Printf.sprintf "Object table base : %04x\n" object_table_base ^ 699 | Printf.sprintf "Global variables table base : %04x\n" global_table_base ^ 700 | Printf.sprintf "Static memory base : %04x\n" static_memory_base ^ 701 | Printf.sprintf "Dictionary base : %04x\n" dictionary_base ^ 702 | Printf.sprintf "High memory base : %04x\n" high_memory_base ^ 703 | Printf.sprintf "Initial program counter : %04x\n" ipc 704 | 705 | let decode_routine_packed_address story (Packed_routine packed) = 706 | match version story with 707 | | V1 708 | | V2 709 | | V3 -> Routine (packed * 2) 710 | | V4 711 | | V5 -> Routine (packed * 4) 712 | | V6 713 | | V7 -> Routine (packed * 4 + (routine_offset story)) 714 | | V8 -> Routine (packed * 8) 715 | 716 | let decode_string_packed_address story (Packed_zstring packed) = 717 | match version story with 718 | | V1 719 | | V2 720 | | V3 -> Zstring (packed * 2) 721 | | V4 722 | | V5 -> Zstring (packed * 4) 723 | | V6 724 | | V7 -> Zstring (packed * 4 + (string_offset story)) 725 | | V8 -> Zstring (packed * 8) 726 | 727 | let load file = 728 | let len = String.length file in 729 | if len < header_size then 730 | failwith (Printf.sprintf "is not a valid story file") 731 | else 732 | let high = dereference_string (address_of_high_byte static_memory_base_offset) file in 733 | let low = dereference_string (address_of_low_byte static_memory_base_offset) file in 734 | let dynamic_length = high * 256 + low in 735 | if dynamic_length > len then 736 | failwith (Printf.sprintf "is not a valid story file") 737 | else 738 | let dynamic = String.sub file 0 dynamic_length in 739 | let static = String.sub file dynamic_length (len - dynamic_length) in 740 | make dynamic static 741 | --------------------------------------------------------------------------------