From 11998b91ca941c652a61a4bd6950b5d8227643f9 Mon Sep 17 00:00:00 2001 From: Neale Pickett Date: Sun, 8 Nov 2009 22:18:18 -0700 Subject: [PATCH] Remove OCS, create plugin system --- .gitignore | 6 + Makefile | 16 +- arf.ml | 8 - bot.ml | 69 +--- bot_ocs.ml | 44 --- callback.ml | 24 -- infobot.ml | 40 +++ ocs-1.0.3/CHANGES | 76 ---- ocs-1.0.3/COPYING | 25 -- ocs-1.0.3/README | 136 ------- ocs-1.0.3/src/.depend | 107 ------ ocs-1.0.3/src/Makefile | 57 --- ocs-1.0.3/src/Makefile.common | 21 -- ocs-1.0.3/src/ocs_char.ml | 153 -------- ocs-1.0.3/src/ocs_char.mli | 9 - ocs-1.0.3/src/ocs_compile.ml | 487 ------------------------- ocs-1.0.3/src/ocs_compile.mli | 13 - ocs-1.0.3/src/ocs_complex.ml | 44 --- ocs-1.0.3/src/ocs_complex.mli | 11 - ocs-1.0.3/src/ocs_contin.ml | 114 ------ ocs-1.0.3/src/ocs_contin.mli | 6 - ocs-1.0.3/src/ocs_env.ml | 143 -------- ocs-1.0.3/src/ocs_env.mli | 30 -- ocs-1.0.3/src/ocs_error.ml | 11 - ocs-1.0.3/src/ocs_eval.ml | 339 ------------------ ocs-1.0.3/src/ocs_eval.mli | 6 - ocs-1.0.3/src/ocs_io.ml | 224 ------------ ocs-1.0.3/src/ocs_io.mli | 11 - ocs-1.0.3/src/ocs_lex.ml | 279 --------------- ocs-1.0.3/src/ocs_lex.mli | 22 -- ocs-1.0.3/src/ocs_list.ml | 302 ---------------- ocs-1.0.3/src/ocs_list.mli | 6 - ocs-1.0.3/src/ocs_macro.ml | 438 ----------------------- ocs-1.0.3/src/ocs_macro.mli | 6 - ocs-1.0.3/src/ocs_main.ml | 28 -- ocs-1.0.3/src/ocs_misc.ml | 77 ---- ocs-1.0.3/src/ocs_misc.mli | 12 - ocs-1.0.3/src/ocs_num.ml | 633 --------------------------------- ocs-1.0.3/src/ocs_num.mli | 13 - ocs-1.0.3/src/ocs_numaux.ml | 201 ----------- ocs-1.0.3/src/ocs_numaux.mli | 29 -- ocs-1.0.3/src/ocs_numstr.ml | 403 --------------------- ocs-1.0.3/src/ocs_numstr.mli | 11 - ocs-1.0.3/src/ocs_port.ml | 128 ------- ocs-1.0.3/src/ocs_port.mli | 26 -- ocs-1.0.3/src/ocs_prim.ml | 269 -------------- ocs-1.0.3/src/ocs_prim.mli | 8 - ocs-1.0.3/src/ocs_print.ml | 75 ---- ocs-1.0.3/src/ocs_print.mli | 9 - ocs-1.0.3/src/ocs_read.ml | 87 ----- ocs-1.0.3/src/ocs_read.mli | 10 - ocs-1.0.3/src/ocs_string.ml | 153 -------- ocs-1.0.3/src/ocs_string.mli | 6 - ocs-1.0.3/src/ocs_sym.ml | 59 --- ocs-1.0.3/src/ocs_sym.mli | 36 -- ocs-1.0.3/src/ocs_top.ml | 75 ---- ocs-1.0.3/src/ocs_top.mli | 10 - ocs-1.0.3/src/ocs_types.mli | 200 ----------- ocs-1.0.3/src/ocs_vartable.ml | 65 ---- ocs-1.0.3/src/ocs_vartable.mli | 13 - ocs-1.0.3/src/ocs_vector.ml | 79 ---- ocs-1.0.3/src/ocs_vector.mli | 6 - ocs-1.0.3/src/ocs_wrap.ml | 35 -- plugin.ml | 24 ++ plugin.mli | 5 + 65 files changed, 79 insertions(+), 5989 deletions(-) create mode 100644 .gitignore delete mode 100644 arf.ml delete mode 100644 bot_ocs.ml delete mode 100644 callback.ml create mode 100644 infobot.ml delete mode 100644 ocs-1.0.3/CHANGES delete mode 100644 ocs-1.0.3/COPYING delete mode 100644 ocs-1.0.3/README delete mode 100644 ocs-1.0.3/src/.depend delete mode 100644 ocs-1.0.3/src/Makefile delete mode 100644 ocs-1.0.3/src/Makefile.common delete mode 100644 ocs-1.0.3/src/ocs_char.ml delete mode 100644 ocs-1.0.3/src/ocs_char.mli delete mode 100644 ocs-1.0.3/src/ocs_compile.ml delete mode 100644 ocs-1.0.3/src/ocs_compile.mli delete mode 100644 ocs-1.0.3/src/ocs_complex.ml delete mode 100644 ocs-1.0.3/src/ocs_complex.mli delete mode 100644 ocs-1.0.3/src/ocs_contin.ml delete mode 100644 ocs-1.0.3/src/ocs_contin.mli delete mode 100644 ocs-1.0.3/src/ocs_env.ml delete mode 100644 ocs-1.0.3/src/ocs_env.mli delete mode 100644 ocs-1.0.3/src/ocs_error.ml delete mode 100644 ocs-1.0.3/src/ocs_eval.ml delete mode 100644 ocs-1.0.3/src/ocs_eval.mli delete mode 100644 ocs-1.0.3/src/ocs_io.ml delete mode 100644 ocs-1.0.3/src/ocs_io.mli delete mode 100644 ocs-1.0.3/src/ocs_lex.ml delete mode 100644 ocs-1.0.3/src/ocs_lex.mli delete mode 100644 ocs-1.0.3/src/ocs_list.ml delete mode 100644 ocs-1.0.3/src/ocs_list.mli delete mode 100644 ocs-1.0.3/src/ocs_macro.ml delete mode 100644 ocs-1.0.3/src/ocs_macro.mli delete mode 100644 ocs-1.0.3/src/ocs_main.ml delete mode 100644 ocs-1.0.3/src/ocs_misc.ml delete mode 100644 ocs-1.0.3/src/ocs_misc.mli delete mode 100644 ocs-1.0.3/src/ocs_num.ml delete mode 100644 ocs-1.0.3/src/ocs_num.mli delete mode 100644 ocs-1.0.3/src/ocs_numaux.ml delete mode 100644 ocs-1.0.3/src/ocs_numaux.mli delete mode 100644 ocs-1.0.3/src/ocs_numstr.ml delete mode 100644 ocs-1.0.3/src/ocs_numstr.mli delete mode 100644 ocs-1.0.3/src/ocs_port.ml delete mode 100644 ocs-1.0.3/src/ocs_port.mli delete mode 100644 ocs-1.0.3/src/ocs_prim.ml delete mode 100644 ocs-1.0.3/src/ocs_prim.mli delete mode 100644 ocs-1.0.3/src/ocs_print.ml delete mode 100644 ocs-1.0.3/src/ocs_print.mli delete mode 100644 ocs-1.0.3/src/ocs_read.ml delete mode 100644 ocs-1.0.3/src/ocs_read.mli delete mode 100644 ocs-1.0.3/src/ocs_string.ml delete mode 100644 ocs-1.0.3/src/ocs_string.mli delete mode 100644 ocs-1.0.3/src/ocs_sym.ml delete mode 100644 ocs-1.0.3/src/ocs_sym.mli delete mode 100644 ocs-1.0.3/src/ocs_top.ml delete mode 100644 ocs-1.0.3/src/ocs_top.mli delete mode 100644 ocs-1.0.3/src/ocs_types.mli delete mode 100644 ocs-1.0.3/src/ocs_vartable.ml delete mode 100644 ocs-1.0.3/src/ocs_vartable.mli delete mode 100644 ocs-1.0.3/src/ocs_vector.ml delete mode 100644 ocs-1.0.3/src/ocs_vector.mli delete mode 100644 ocs-1.0.3/src/ocs_wrap.ml create mode 100644 plugin.ml create mode 100644 plugin.mli diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ae2fb91 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*.cmi +*.cmo +*~ +bot +.omake* +.depend diff --git a/Makefile b/Makefile index ef4bfab..1a75df0 100644 --- a/Makefile +++ b/Makefile @@ -1,25 +1,13 @@ -OCS_VERSION = 1.0.3 -OCS_DIR = ocs-$(OCS_VERSION) - - -INCLUDES = -I $(OCS_DIR)/src +INCLUDES = OCAMLFLAGS = $(INCLUDES) OCAMLOPT = ocamlopt OCAMLC = ocamlc OCAMLDEP = ocamldep $(INCLUDES) OCAMLLIBS = unix.cma str.cma nums.cma -bot: irc.cmo dispatch.cmo command.cmo iobuf.cmo cdb.cmo bot.cmo -bot: $(OCS_DIR)/src/ocs.cma +bot: irc.cmo dispatch.cmo command.cmo iobuf.cmo cdb.cmo bindings.cmo plugin.cmo infobot.cmo bot.cmo infobot.cmo $(OCAMLC) -o $@ $(OCAMLLIBS) $^ -callback: callback.cmo -callback: $(OCS_DIR)/src/ocs.cma - $(OCAMLC) -o $@ $(OCAMLLIBS) $^ - -$(OCS_DIR)/src/ocs.cma $(OCS_DIR)/src/ocs.cmxa: $(OCS_DIR) - cd $(OCS_DIR)/src && make - .PHONY: clean clean: rm -f bot *.cm* *.o diff --git a/arf.ml b/arf.ml deleted file mode 100644 index 61faeb2..0000000 --- a/arf.ml +++ /dev/null @@ -1,8 +0,0 @@ -type goob = Goob of (int ref) * int - -let _ = - let a = Goob (ref 1, 2) in - if (match a with - | Goob ({contents = 1}, _) -> true - | _ -> false) then - print_endline "hi asl" diff --git a/bot.ml b/bot.ml index 8b37d49..b11b9b4 100644 --- a/bot.ml +++ b/bot.ml @@ -1,71 +1,8 @@ -let info_db = Cdb.open_cdb_in "/home/neale/src/firebot/info.cdb" -let _ = Random.self_init () - -let choice l = - let n = Random.int (List.length l) in - List.nth l n - -let choose_one key = - let matches = Cdb.get_matches info_db key in - match Stream.npeek 120 matches with - | [] -> raise Not_found - | keys -> choice keys - let write iobuf command args text = let cmd = Command.create None command args text in print_endline ("--> " ^ (Command.as_string cmd)); Iobuf.write iobuf cmd -let make_sandbox_env () = - let e = Ocs_env.top_env () in - Ocs_compile.bind_lang e; - Ocs_macro.bind_macro e; - Ocs_num.init e; - Ocs_numstr.init e; - Ocs_prim.init e; - Ocs_vector.init e; - Ocs_list.init e; - Ocs_char.init e; - Ocs_string.init e; - Ocs_contin.init e; - e - -let scheme_eval str = - try - let thread = Ocs_top.make_thread () in - let env = make_sandbox_env () in - let inport = Ocs_port.open_input_string str in - let outport = Ocs_port.open_output_string () in - let lexer = Ocs_lex.make_lexer inport "interactive" in - let v = Ocs_read.read_expr lexer in - let c = Ocs_compile.compile env v in - Ocs_eval.eval thread (Ocs_print.print outport false) c; - Ocs_port.get_output_string outport - with - | Ocs_error.Error msg - | Ocs_error.ErrorL (_, msg) -> - "Error: " ^ msg - - -let handle_privmsg iobuf sender target text = - try - let factoid = choose_one text in - let response = - match factoid.[0] with - | ':' -> - "\001ACTION " ^ (Str.string_after factoid 1) ^ "\001" - | '\\' -> - Str.string_after factoid 1 - | _ -> - Printf.sprintf "I've heard that %s is %s" text factoid - in - write iobuf "PRIVMSG" [target] (Some response) - with Not_found -> - if text.[0] == '(' then - let result = scheme_eval text in - write iobuf "PRIVMSG" [target] (Some result) - - let handle_command iobuf cmd = print_endline ("<-- " ^ (Command.as_string cmd)); match Command.as_tuple cmd with @@ -75,9 +12,6 @@ let handle_command iobuf cmd = write iobuf "JOIN" ["#bot"] None | (Some sender, "JOIN", [], Some chan) -> write iobuf "PRIVMSG" [chan] (Some "hi asl") - | (Some sender, "PRIVMSG", [target], Some text) -> - if Irc.is_channel target then - handle_privmsg iobuf sender target text | _ -> () @@ -89,7 +23,8 @@ let main () = let dispatcher = Dispatch.create 5 in let conn = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in let _ = Unix.connect conn (Unix.ADDR_INET (host.Unix.h_addr_list.(0), 6667)) in - let iobuf = Iobuf.create dispatcher conn "woozle" handle_command handle_error in + let iobuf = Iobuf.create dispatcher conn "woozle" Plugin.handle_command handle_error in + Plugin.register handle_command; write iobuf "NICK" ["bot"] None; write iobuf "USER" ["bot"; "bot"; "bot"] (Some "A Bot"); Dispatch.run dispatcher diff --git a/bot_ocs.ml b/bot_ocs.ml deleted file mode 100644 index 0af42db..0000000 --- a/bot_ocs.ml +++ /dev/null @@ -1,44 +0,0 @@ -open Ocs_types - -module Iobuf = - Ocs_wrap.Make (struct - type t = Iobuf.t - end) - -let rec string_list_of_spair v acc = - match v with - | Snull -> - acc - | Spair { car = Sstring s; cdr = cdr } -> - string_list_of_spair cdr (acc @ s) - | _ -> - raise Ocs_error.Error "Not a string list" - -let write_vals iobuf vals = - let cmd = - match vals with - | [| Swrapped iobuf; Sstring command; Spair args; Sstring text |] -> - Command.create None command (string_list_of_spair args) (Some text) - | [| Swrapped iobuf; Sstring command; Spair args |] -> - Command.create None command (string_list_of_spair args) None - | _ -> - raise Ocs_error.Error "Invalid arguments" - in - Iobuf.write iobuf cmd - -let iobuf_write_proc iobuf = - let primf = Pfn (write_vals iobuf) in - let sprim = { prim_fun = primf; prim_name = "iobuf-write" } in - Sproc (sprim, [| [| |] |]) - -let ocs_bind b regexp cb = - match (regexp, cb) with - | (Sstring regexp_s, Sproc (p, d)) -> - let regexp = Str.regexp regexp_s in - b := Bindings.add (regexp_s, regexp, p) - | _ -> - raise Ocs_error.Error "invalid arguments" - -let init b e = - set_pf3 e (ocs_bind b) "bind" - diff --git a/callback.ml b/callback.ml deleted file mode 100644 index 44dcdac..0000000 --- a/callback.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Ocs_types - -let prefix_print prefix = - function - | [| Sstring txt |] -> - print_endline (prefix ^ txt); - Sunspec - | _ -> - raise (Ocs_error.Error "Invalid arguments") - -let prefix_print_proc prefix = - let primf = Pfn (prefix_print prefix) in - let sprim = { prim_fun = primf; prim_name = "iobuf-write" } in - Sprim sprim - -let code = - Capply1 ((Cval (prefix_print_proc "pfx: ")), - (Cval (Sstring "hello world"))) - -let _ = - let thread = Ocs_top.make_thread () in - let outport = Ocs_port.open_output_string () in - Ocs_eval.eval thread (Ocs_print.print outport false) code; - Ocs_port.get_output_string outport diff --git a/infobot.ml b/infobot.ml new file mode 100644 index 0000000..2f0e9ef --- /dev/null +++ b/infobot.ml @@ -0,0 +1,40 @@ +let info_db = Cdb.open_cdb_in "/home/neale/src/firebot/info.cdb" +let _ = Random.self_init () + +let choice l = + let n = Random.int (List.length l) in + List.nth l n + +let choose_one key = + let matches = Cdb.get_matches info_db key in + match Stream.npeek 120 matches with + | [] -> raise Not_found + | keys -> choice keys + +let handle_privmsg iobuf sender target text = + try + let factoid = choose_one text in + let response = + match factoid.[0] with + | ':' -> + "\001ACTION " ^ (Str.string_after factoid 1) ^ "\001" + | '\\' -> + Str.string_after factoid 1 + | _ -> + Printf.sprintf "I've heard that %s is %s" text factoid + in + Iobuf.write iobuf (Command.create None "PRIVMSG" [target] (Some response)) + with Not_found -> + () + +let handle_command iobuf cmd = + print_endline (" + if Irc.is_channel target then + handle_privmsg iobuf sender target text + | _ -> + () + +let _ = Plugin.register handle_command +let _ = print_endline "========= INFOBOT" diff --git a/ocs-1.0.3/CHANGES b/ocs-1.0.3/CHANGES deleted file mode 100644 index d13f09c..0000000 --- a/ocs-1.0.3/CHANGES +++ /dev/null @@ -1,76 +0,0 @@ -1.0.3 - - - The various let forms now create new frames. This fixes - behavior for situations where the initializers for the bound - variables return multiple times due to captured continuations. - - - Change define-syntax to return the unspecified value. - - - Fix (lambda ...) forms where is env-tagged by - macro expansion. - -1.0.2 - - - Try to find a smaller invariant precision when converting from - floating point values to strings. - - - Add missing function vector-fill!. - - - Add an unspecified value that isn't printed by the repl. - - - Add a value and functor that can be used to safely wrap arbitrary - OCaml values in Scheme values. - - - Fix internal definitions inside (begin ...) forms. - - - Consider literals in the literal list of syntax-rules locally - bound while parsing (but not while matching) patterns. R5RS is not - clear on this, but it is necessary to avoid breaking hygiene when - some expansions of an outer macro could change the interpretation of - pattern variables to literals within the patterns of inner macros. - This seems consistent with the behavior of other implementations. - - - Fix namespace lookup for syntax-rules literals to allow changes - in global bindings. - - - Fix namespace handling for nested macros. - - - Fix copy-paste error in log. - - - Fix the behavior of eval and arguments. - - - Fix inexact->exact for negative numbers that don't fit into an - integer. - - - The reader now also accepts square brackets [ and ] as list - delimiters. - - - Fix remainder to handle differing signs correctly. - -1.0.1 - - - Fix sorting of byte code objects in Makefile. - - - Add missing functions numerator and denominator. - - - Keep rationals normalized. - -1.0 (changes from pre-releases) - - - Rearrange build to generate bytecode and native libraries and a - native interpreter usable from the command line. - - - Remove CVS Id's (the project is now being stored in a GNU Arch - repository) from all files. - - - Fix Ocs_port.string_input_port to actually initialize the - port with the string length. - - - Fix internal definitions of the form (define (fun args ...) ...). - Previously the first item of the body would be skipped. - - - Fix the order of arguments to atan when called with two arguments. - - - When invoking continuations with multiple arguments, the - arguments are now wrapped with Svalues as if (values ...) were used. - diff --git a/ocs-1.0.3/COPYING b/ocs-1.0.3/COPYING deleted file mode 100644 index a54d963..0000000 --- a/ocs-1.0.3/COPYING +++ /dev/null @@ -1,25 +0,0 @@ - -Copyright (c) 2003-2004 Ville-Pertti Keinonen -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. - diff --git a/ocs-1.0.3/README b/ocs-1.0.3/README deleted file mode 100644 index 768d180..0000000 --- a/ocs-1.0.3/README +++ /dev/null @@ -1,136 +0,0 @@ -1. General - -Ocs is an implementation of Scheme, as defined by R5RS. It is -written entirely in OCaml and can be trivially embedded in any -OCaml program. - -Known deviations from R5RS: - - - transcript-on and transcript-off are currently not implemented - - scheme-report-environment and null-environment ignore their - argument - -Anything else that does not work as specified in R5RS is a bug. - - -2. Installation - -Requirements: - - - GNU make or pmake (BSD make) - - OCaml 3.x (versions 3.06 and newer tested) - -Type make or gmake in the src directory. This should produce the -following: - - - A bytecode library (ocs.cma) - - A native library (ocs.cmxa, ocs.a) - - A stand-alone, native interpreter (ocscm) - -2.1 The 'ocscm' command - -If invoked without arguments, the interpreter will run in interactive -mode. - -If invoked with arguments, the interpreter will read and evaluate -the files listed as arguments and exit. The evaluation results are -not printed. - - -3. Implementation Details - -Implementing Scheme in OCaml is so straightforward that it hardly -needs any documentation. The following mappings between languages -are done: - - - Scheme is dynamically typed. Scheme values are represented by -the OCaml type Ocs_types.sval. - - - In Scheme, top-level bindings are global and all variables are -mutable. Variables references are bound through environments -(Ocs_types.env) to global slots (Ocs_types.gvar) or frame indices -(the actual frames are visible at evaluation-time through -Ocs_types.thread). - - - Scheme has capturable, first-class continuations. Most of the -evaluator is written in continuation-passing style in order to allow -this. - -Where discussing types, the rest of this section assumes that the -types defined in the module Ocs_types are visible. - -3.1 Evaluation - -Scheme values (S-expressions) are of the type sval. - -Before evaluation Scheme values are compiled to internal representations -of the type code. This is done by the function - - Ocs_compile.compile : env -> sval -> code - -The env type is used during compilation for variable bindings. A -new env is created for each new scope and frame. The base -environment with the basic language bindings can be created using - - Ocs_top.make_env : unit -> env - -Evaluation is done by - - Ocs_eval.eval : thread -> (sval -> unit) -> code -> unit - -where the second argument is a continuation to pass the result to. - -The thread type is used during evaluation for storing the current -frame and display for local variables, the input/output ports and -the current dynamic extent. It does not represent a thread in the -concurrent sense, but rather the evaluation state, and is copied and -changed rather than modified in place. The initial thread to be -passed to the evaluator can be created using -Ocs_top.make_thread : unit -> thread. - -3.2 Continuations and I/O - -Any continuations captured are associated with the thread at the -time of capture, so if a continuation is used to escape a -with-input-from-file or with-output-to-file, the input/output port -is restored to those of the time of capture. - -If a continuation is used to return to a with-input-from-file or -with-output-to-file, the port is once again set to the one -opened by the with-...-file call. However, if the thunk has -already exited once, the port will be closed and no longer be -valid for I/O calls. - -3.3 Numbers - -The full R5RS numeric tower is implemented, with the following -internal representations: - -Exact numbers are - - 31- or 63-bit integers (OCaml int) - - Big_int objects from the Num library when unboxed integers are - too small - - Ratio objects from the Num library for rationals - -Inexact numbers are - - 64-bit IEEE floats for reals (OCaml float) - - Pairs of 64-bit IEEE floats for complex numbers (OCaml Complex.t) - -Since inexact numbers are represented internally as binary floating -point, conversions to exact numbers are most precise for fractions of -powers of two - - (inexact->exact 2.125) ==> 17/8 - -compared to - - (inexact->exact 0.3) ==> 5404319552844595/18014398509481984 - -And in fact many rationals will not satisfy - - (= (inexact->exact (exact->inexact r)) r) - -However - - (rationalize (inexact->exact 0.3) (expt 2 -54)) ==> 3/10 - diff --git a/ocs-1.0.3/src/.depend b/ocs-1.0.3/src/.depend deleted file mode 100644 index 2ce83d6..0000000 --- a/ocs-1.0.3/src/.depend +++ /dev/null @@ -1,107 +0,0 @@ -ocs_char.cmo: ocs_types.cmi ocs_error.cmo ocs_env.cmi ocs_char.cmi -ocs_char.cmx: ocs_types.cmi ocs_error.cmx ocs_env.cmx ocs_char.cmi -ocs_compile.cmo: ocs_vartable.cmi ocs_types.cmi ocs_sym.cmi ocs_misc.cmi \ - ocs_error.cmo ocs_env.cmi ocs_compile.cmi -ocs_compile.cmx: ocs_vartable.cmx ocs_types.cmi ocs_sym.cmx ocs_misc.cmx \ - ocs_error.cmx ocs_env.cmx ocs_compile.cmi -ocs_complex.cmo: ocs_complex.cmi -ocs_complex.cmx: ocs_complex.cmi -ocs_contin.cmo: ocs_types.cmi ocs_misc.cmi ocs_eval.cmi ocs_error.cmo \ - ocs_env.cmi ocs_contin.cmi -ocs_contin.cmx: ocs_types.cmi ocs_misc.cmx ocs_eval.cmx ocs_error.cmx \ - ocs_env.cmx ocs_contin.cmi -ocs_env.cmo: ocs_vartable.cmi ocs_types.cmi ocs_sym.cmi ocs_error.cmo \ - ocs_env.cmi -ocs_env.cmx: ocs_vartable.cmx ocs_types.cmi ocs_sym.cmx ocs_error.cmx \ - ocs_env.cmi -ocs_eval.cmo: ocs_types.cmi ocs_sym.cmi ocs_misc.cmi ocs_error.cmo \ - ocs_eval.cmi -ocs_eval.cmx: ocs_types.cmi ocs_sym.cmx ocs_misc.cmx ocs_error.cmx \ - ocs_eval.cmi -ocs_io.cmo: ocs_types.cmi ocs_read.cmi ocs_print.cmi ocs_port.cmi \ - ocs_eval.cmi ocs_error.cmo ocs_env.cmi ocs_io.cmi -ocs_io.cmx: ocs_types.cmi ocs_read.cmx ocs_print.cmx ocs_port.cmx \ - ocs_eval.cmx ocs_error.cmx ocs_env.cmx ocs_io.cmi -ocs_lex.cmo: ocs_types.cmi ocs_port.cmi ocs_numstr.cmi ocs_error.cmo \ - ocs_char.cmi ocs_lex.cmi -ocs_lex.cmx: ocs_types.cmi ocs_port.cmx ocs_numstr.cmx ocs_error.cmx \ - ocs_char.cmx ocs_lex.cmi -ocs_list.cmo: ocs_types.cmi ocs_misc.cmi ocs_error.cmo ocs_env.cmi \ - ocs_list.cmi -ocs_list.cmx: ocs_types.cmi ocs_misc.cmx ocs_error.cmx ocs_env.cmx \ - ocs_list.cmi -ocs_macro.cmo: ocs_types.cmi ocs_sym.cmi ocs_misc.cmi ocs_error.cmo \ - ocs_env.cmi ocs_compile.cmi ocs_macro.cmi -ocs_macro.cmx: ocs_types.cmi ocs_sym.cmx ocs_misc.cmx ocs_error.cmx \ - ocs_env.cmx ocs_compile.cmx ocs_macro.cmi -ocs_main.cmo: ocs_types.cmi ocs_top.cmi ocs_prim.cmi ocs_error.cmo -ocs_main.cmx: ocs_types.cmi ocs_top.cmx ocs_prim.cmx ocs_error.cmx -ocs_misc.cmo: ocs_types.cmi ocs_error.cmo ocs_misc.cmi -ocs_misc.cmx: ocs_types.cmi ocs_error.cmx ocs_misc.cmi -ocs_num.cmo: ocs_types.cmi ocs_numaux.cmi ocs_error.cmo ocs_env.cmi \ - ocs_complex.cmi ocs_num.cmi -ocs_num.cmx: ocs_types.cmi ocs_numaux.cmx ocs_error.cmx ocs_env.cmx \ - ocs_complex.cmx ocs_num.cmi -ocs_numaux.cmo: ocs_types.cmi ocs_error.cmo ocs_numaux.cmi -ocs_numaux.cmx: ocs_types.cmi ocs_error.cmx ocs_numaux.cmi -ocs_numstr.cmo: ocs_types.cmi ocs_numaux.cmi ocs_num.cmi ocs_error.cmo \ - ocs_env.cmi ocs_numstr.cmi -ocs_numstr.cmx: ocs_types.cmi ocs_numaux.cmx ocs_num.cmx ocs_error.cmx \ - ocs_env.cmx ocs_numstr.cmi -ocs_port.cmo: ocs_error.cmo ocs_port.cmi -ocs_port.cmx: ocs_error.cmx ocs_port.cmi -ocs_prim.cmo: ocs_types.cmi ocs_sym.cmi ocs_read.cmi ocs_port.cmi \ - ocs_misc.cmi ocs_macro.cmi ocs_lex.cmi ocs_io.cmi ocs_eval.cmi \ - ocs_error.cmo ocs_env.cmi ocs_compile.cmi ocs_prim.cmi -ocs_prim.cmx: ocs_types.cmi ocs_sym.cmx ocs_read.cmx ocs_port.cmx \ - ocs_misc.cmx ocs_macro.cmx ocs_lex.cmx ocs_io.cmx ocs_eval.cmx \ - ocs_error.cmx ocs_env.cmx ocs_compile.cmx ocs_prim.cmi -ocs_print.cmo: ocs_types.cmi ocs_sym.cmi ocs_port.cmi ocs_numstr.cmi \ - ocs_char.cmi ocs_print.cmi -ocs_print.cmx: ocs_types.cmi ocs_sym.cmx ocs_port.cmx ocs_numstr.cmx \ - ocs_char.cmx ocs_print.cmi -ocs_read.cmo: ocs_types.cmi ocs_sym.cmi ocs_port.cmi ocs_misc.cmi ocs_lex.cmi \ - ocs_error.cmo ocs_read.cmi -ocs_read.cmx: ocs_types.cmi ocs_sym.cmx ocs_port.cmx ocs_misc.cmx ocs_lex.cmx \ - ocs_error.cmx ocs_read.cmi -ocs_string.cmo: ocs_types.cmi ocs_error.cmo ocs_env.cmi ocs_string.cmi -ocs_string.cmx: ocs_types.cmi ocs_error.cmx ocs_env.cmx ocs_string.cmi -ocs_sym.cmo: ocs_types.cmi ocs_error.cmo ocs_sym.cmi -ocs_sym.cmx: ocs_types.cmi ocs_error.cmx ocs_sym.cmi -ocs_top.cmo: ocs_vector.cmi ocs_types.cmi ocs_string.cmi ocs_read.cmi \ - ocs_print.cmi ocs_prim.cmi ocs_port.cmi ocs_numstr.cmi ocs_num.cmi \ - ocs_macro.cmi ocs_list.cmi ocs_lex.cmi ocs_io.cmi ocs_eval.cmi \ - ocs_error.cmo ocs_env.cmi ocs_contin.cmi ocs_compile.cmi ocs_char.cmi \ - ocs_top.cmi -ocs_top.cmx: ocs_vector.cmx ocs_types.cmi ocs_string.cmx ocs_read.cmx \ - ocs_print.cmx ocs_prim.cmx ocs_port.cmx ocs_numstr.cmx ocs_num.cmx \ - ocs_macro.cmx ocs_list.cmx ocs_lex.cmx ocs_io.cmx ocs_eval.cmx \ - ocs_error.cmx ocs_env.cmx ocs_contin.cmx ocs_compile.cmx ocs_char.cmx \ - ocs_top.cmi -ocs_vartable.cmo: ocs_vartable.cmi -ocs_vartable.cmx: ocs_vartable.cmi -ocs_vector.cmo: ocs_types.cmi ocs_error.cmo ocs_env.cmi ocs_vector.cmi -ocs_vector.cmx: ocs_types.cmi ocs_error.cmx ocs_env.cmx ocs_vector.cmi -ocs_wrap.cmo: ocs_types.cmi ocs_error.cmo -ocs_wrap.cmx: ocs_types.cmi ocs_error.cmx -ocs_char.cmi: ocs_types.cmi -ocs_compile.cmi: ocs_types.cmi -ocs_contin.cmi: ocs_types.cmi -ocs_env.cmi: ocs_types.cmi ocs_sym.cmi -ocs_eval.cmi: ocs_types.cmi -ocs_io.cmi: ocs_types.cmi -ocs_lex.cmi: ocs_types.cmi ocs_port.cmi ocs_error.cmo -ocs_list.cmi: ocs_types.cmi -ocs_macro.cmi: ocs_types.cmi -ocs_misc.cmi: ocs_types.cmi -ocs_num.cmi: ocs_types.cmi -ocs_numaux.cmi: ocs_types.cmi -ocs_numstr.cmi: ocs_types.cmi -ocs_prim.cmi: ocs_types.cmi -ocs_print.cmi: ocs_types.cmi ocs_port.cmi -ocs_read.cmi: ocs_types.cmi ocs_port.cmi ocs_lex.cmi -ocs_string.cmi: ocs_types.cmi -ocs_sym.cmi: ocs_types.cmi -ocs_top.cmi: ocs_types.cmi -ocs_types.cmi: ocs_vartable.cmi ocs_port.cmi -ocs_vector.cmi: ocs_types.cmi diff --git a/ocs-1.0.3/src/Makefile b/ocs-1.0.3/src/Makefile deleted file mode 100644 index 67b19b0..0000000 --- a/ocs-1.0.3/src/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -# -# Build system for ocs library and interpreter -# - -include Makefile.common - -BC_LIB = ocs.cma -N_LIB = ocs.cmxa -C_LIB = ocs.a -INTERP = ocscm - -BC_OBJS = ocs_error.cmo ocs_port.cmo ocs_vartable.cmo ocs_sym.cmo \ - ocs_env.cmo ocs_char.cmo ocs_complex.cmo ocs_numaux.cmo \ - ocs_num.cmo ocs_numstr.cmo ocs_lex.cmo ocs_misc.cmo ocs_read.cmo \ - ocs_eval.cmo ocs_compile.cmo ocs_contin.cmo ocs_print.cmo \ - ocs_io.cmo ocs_list.cmo ocs_macro.cmo ocs_prim.cmo ocs_string.cmo \ - ocs_vector.cmo ocs_wrap.cmo ocs_top.cmo - -N_OBJS = ocs_error.cmx ocs_sym.cmx ocs_vartable.cmx ocs_env.cmx \ - ocs_char.cmx ocs_misc.cmx ocs_compile.cmx ocs_eval.cmx \ - ocs_contin.cmx ocs_port.cmx ocs_complex.cmx ocs_numaux.cmx \ - ocs_num.cmx ocs_numstr.cmx ocs_print.cmx ocs_lex.cmx ocs_read.cmx \ - ocs_io.cmx ocs_list.cmx ocs_macro.cmx ocs_prim.cmx ocs_string.cmx \ - ocs_vector.cmx ocs_wrap.cmx ocs_top.cmx - -INTERP_OBJS = ocs_main.cmx - -BCI_OBJS = ocs_main.cmo -BCI = ocscm-bc - -all: $(BC_LIB) $(N_LIB) $(INTERP) - -native: $(N_LIB) - -bytecode: $(BC_LIB) - -$(N_LIB): $(N_OBJS) - $(OCAMLOPT) -a -o $(N_LIB) $(N_OBJS) - -$(BC_LIB): $(BC_OBJS) - $(OCAMLC) -a -o $(BC_LIB) $(BC_OBJS) - -$(INTERP): $(N_LIB) $(INTERP_OBJS) - $(OCAMLOPT) -o $(INTERP) nums.cmxa unix.cmxa $(N_LIB) $(INTERP_OBJS) - -$(BCI): $(BC_LIB) $(BCI_OBJS) - $(OCAMLC) $(OCAMLFLAGS) -o $(BCI) nums.cma unix.cma $(BC_LIB) $(BCI_OBJS) - -clean: - -rm -f $(N_LIB) $(BC_LIB) $(C_LIB) $(INTERP) *.cm* *.o - -rm -f $(BCI) - -depend: - $(OCAMLDEP) *.ml *.mli > .depend - -include .depend - diff --git a/ocs-1.0.3/src/Makefile.common b/ocs-1.0.3/src/Makefile.common deleted file mode 100644 index 9ac5f71..0000000 --- a/ocs-1.0.3/src/Makefile.common +++ /dev/null @@ -1,21 +0,0 @@ -# -# General OCaml build settings -# - -OCAMLOPT = ocamlopt -OCAMLC = ocamlc -OCAMLDEP = ocamldep - -OCAMLFLAGS = - -.SUFFIXES: .o .c .h .cc .cpp .y .l .a .ml .mli .cmx .cmi .cmo - -.mli.cmi: - $(OCAMLC) $(OCAMLFLAGS) -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLFLAGS) -c $< - -.ml.cmo: - $(OCAMLC) $(OCAMLFLAGS) -c $< - diff --git a/ocs-1.0.3/src/ocs_char.ml b/ocs-1.0.3/src/ocs_char.ml deleted file mode 100644 index 26434be..0000000 --- a/ocs-1.0.3/src/ocs_char.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* Character primitives *) - -open Ocs_types -open Ocs_error -open Ocs_env - -(* Character name equivalents (long). *) -let char_long_names = - [| - "space", ' '; - "newline", '\n'; - - (* The rest are extensions. *) - "return", '\r'; - "tab", '\t'; - "backspace", '\008'; - "escape", '\027'; - "backslash", '\\'; - "alarm", '\007'; - "vtab", '\011'; - "del", '\127' |] -;; - -(* Table of short names for 0 .. 31 *) -let char_short_names = - [| "nul"; "soh"; "stx"; "etx"; "eot"; "enq"; "ack"; "bel"; - "bs"; "ht"; "nl"; "vt"; "np"; "cr"; "so"; "si"; - "dle"; "dc1"; "dc2"; "dc3"; "dc4"; "nak"; "syn"; "etb"; - "can"; "em"; "sub"; "esc"; "fs"; "gs"; "rs"; "us" |] -;; - -let name_to_char name = - let name = (String.lowercase name) - and ln = Array.length char_long_names - and sn = Array.length char_short_names in - let rec lloop i = - if i = ln then sloop 0 - else - match char_long_names.(i) with - (n, c) -> if n = name then Some c else lloop (i + 1) - and sloop i = - if i = sn then None - else if char_short_names.(i) = name then Some (char_of_int i) - else sloop (i + 1) - in - lloop 0 -;; - -(* Generate the preferred printed literal form of a character. *) -let char_to_name = - function - '\n' -> "newline" - | ' ' -> "space" - | '\127' -> "del" - | '\000' .. '\031' as c -> char_short_names.(int_of_char c) - | '\033' .. '\126' as c -> String.make 1 c - | c -> Printf.sprintf "x%02x" (int_of_char c) -;; - -let char_cmp op c1 c2 = - match (c1, c2) with - (Schar c1, Schar c2) -> if op c1 c2 then Strue else Sfalse - | _ -> raise (Error "args not characters") -;; - -let char_eq = char_cmp (=);; -let char_lt = char_cmp (<);; -let char_gt = char_cmp (>);; -let char_le = char_cmp (<=);; -let char_ge = char_cmp (>=);; - -let char_ci_cmp op c1 c2 = - match (c1, c2) with - (Schar c1, Schar c2) -> - if op (Char.lowercase c1) (Char.lowercase c2) then Strue else Sfalse - | _ -> raise (Error "args not characters") -;; - -let char_ci_eq = char_ci_cmp (=);; -let char_ci_lt = char_ci_cmp (<);; -let char_ci_gt = char_ci_cmp (>);; -let char_ci_le = char_ci_cmp (<=);; -let char_ci_ge = char_ci_cmp (>=);; - -let char_unop op = - function - Schar c -> op c - | _ -> raise (Error "arg not character") -;; - -let char_alphabetic = - char_unop (function 'A' .. 'Z' | 'a' ..'z' -> Strue | _ -> Sfalse) -;; - -let char_numeric = - char_unop (function '0' ..'9' -> Strue | _ -> Sfalse) -;; - -let char_whitespace = - char_unop (function ' ' | '\t' | '\r' | '\n' | '\012' -> Strue | _ -> Sfalse) -;; - -let char_uppercase = - char_unop (function 'A' .. 'Z' -> Strue | _ -> Sfalse) -;; - -let char_lowercase = - char_unop (function 'a' .. 'z' -> Strue | _ -> Sfalse) -;; - -let char_integer = - char_unop (fun c -> Sint (int_of_char c)) -;; - -let integer_char = - function - Sint i -> Schar (char_of_int i) - | _ -> raise (Error "arg not int") -;; - -let char_upcase = - char_unop (fun c -> Schar (Char.uppercase c)) -;; - -let char_downcase = - char_unop (fun c -> Schar (Char.lowercase c)) -;; - -let init e = - set_pf2 e char_eq "char=?"; - set_pf2 e char_lt "char?"; - set_pf2 e char_le "char<=?"; - set_pf2 e char_ge "char>=?"; - - set_pf2 e char_ci_eq "char-ci=?"; - set_pf2 e char_ci_lt "char-ci?"; - set_pf2 e char_ci_le "char-ci<=?"; - set_pf2 e char_ci_ge "char-ci>=?"; - - set_pf1 e char_alphabetic "char-alphabetic?"; - set_pf1 e char_numeric "char-numeric?"; - set_pf1 e char_whitespace "char-whitespace?"; - set_pf1 e char_uppercase "char-upper-case?"; - set_pf1 e char_lowercase "char-lower-case?"; - - set_pf1 e char_integer "char->integer"; - set_pf1 e integer_char "integer->char"; - - set_pf1 e char_upcase "char-upcase"; - set_pf1 e char_downcase "char-downcase"; -;; diff --git a/ocs-1.0.3/src/ocs_char.mli b/ocs-1.0.3/src/ocs_char.mli deleted file mode 100644 index 40b350b..0000000 --- a/ocs-1.0.3/src/ocs_char.mli +++ /dev/null @@ -1,9 +0,0 @@ -(* Character primitives. *) - -open Ocs_types - -val name_to_char : string -> char option -val char_to_name : char -> string - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_compile.ml b/ocs-1.0.3/src/ocs_compile.ml deleted file mode 100644 index 411ea4f..0000000 --- a/ocs-1.0.3/src/ocs_compile.ml +++ /dev/null @@ -1,487 +0,0 @@ -(* Compile Scheme expressions into a form that can be evaluated efficiently. *) - -open Ocs_types -open Ocs_error -open Ocs_sym -open Ocs_misc -open Ocs_env -open Ocs_vartable - -(* Split the variables that are arguments to let/let*/letrec *) -let letsplit f = - function - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; - cdr = Spair { car = v; cdr = Snull }} -> f s v - | _ -> raise (Error "invalid let arglist") -;; - -(* Split the variables that are arguments to do *) -let dosplit f = - function - Spair { car = (Ssymbol _ | Sesym (_, _)) as sym; - cdr = Spair { car = init; cdr = t }} -> - begin - match t with - Snull -> f sym init sym - | Spair { car = step; cdr = Snull } -> f sym init step - | _ -> raise (Error "invalid do arglist") - end - | _ -> raise (Error "invalid do arglist") -;; - -let genset b v = - match b with - Vglob g -> Csetg (g, v) - | Vloc (d, i) -> Csetl (d, i, v) - | _ -> raise (Error "cannot change syntactic keywords") -;; - -let gendef b v = - match b with - Vglob g -> Cdefine (g, v) - | Vloc (d, i) -> Csetl (d, i, v) - | _ -> raise (Error "cannot change syntactic keywords") -;; - -let genref = - function - Vglob g -> Cgetg g - | Vloc (d, i) -> Cgetl (d, i) - | Vsyntax _ -> Cval Sunspec - | Vmacro _ -> Cval Sunspec - | Vkeyword _ -> Cval Sunbound -;; - -let mkseq s = - match Array.length s with - 0 -> Cval Sunspec - | 1 -> s.(0) - | 2 -> Cseq2 (s.(0), s.(1)) - | 3 -> Cseq3 (s.(0), s.(1), s.(2)) - | _ -> Cseqn s -;; - -let mkand s = - match Array.length s with - 0 -> Cval Strue - | 1 -> s.(0) - | 2 -> Cand2 (s.(0), s.(1)) - | 3 -> Cand3 (s.(0), s.(1), s.(2)) - | _ -> Candn s -;; - -let mkor s = - match Array.length s with - 0 -> Cval Sfalse - | 1 -> s.(0) - | 2 -> Cor2 (s.(0), s.(1)) - | 3 -> Cor3 (s.(0), s.(1), s.(2)) - | _ -> Corn s -;; - -let make_proc c n hr fs = - { proc_body = c; - proc_nargs = n; - proc_has_rest = hr; - proc_frame_size = fs; - proc_name = "##" } -;; - -let chksplice a = - let n = Array.length a in - let rec loop i = - if i < n then - begin - match a.(i) with - Cqqspl _ -> true - | _ -> loop (i + 1) - end - else - false - in - loop 0 -;; - -(* Scan quoted sections, eliminate environment-specific symbols *) -let rec scanquoted = - function - Sesym (_, sym) -> sym - | Spair { car = h; cdr = t } -> - Spair { car = scanquoted h; cdr = scanquoted t } - | Svector v -> - Svector (Array.map (fun x -> scanquoted x) v) - | x -> x -;; - -let is_uglobal e = - vt_global e.env_vartable -;; - -let is_global e = - e.env_depth < 0 -;; - -let rec mkdefine e args = - let narg = Array.length args in - if narg < 1 then - raise (Error "define: not enough args"); - match args.(0) with - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = al } when narg > 1 -> - begin - match mklambda e al args with - Clambda p as l -> - p.proc_name <- sym_name s; - gendef (get_var e s) l - | _ -> assert false - end - | (Ssymbol _ | Sesym (_, _)) as s when narg = 2 -> - gendef (get_var e s) (compile e args.(1)) - | (Ssymbol _ | Sesym (_, _)) as s when narg = 1 -> - gendef (get_var e s) (Cval Sunspec) - | _ -> raise (Error "define: invalid syntax") - -(* The following functions up to mkbody are used to compile the body - of a lambda, let etc., with possible internal definitions. The - internal definitions may be created by macro expansion, so we need - to do that here, too...and we might end up expanding a macro more - than once (so there must be no side-effects to expansion). *) -and idpp = - function - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; - cdr = Spair { car = v; cdr = Snull }} -> (s, s, v) - | Spair { car = Spair { car = (Ssymbol _ | Sesym (_, _)) as s; - cdr = _ } as x; - cdr = _ } as v -> (s, x, v) - | _ -> raise (Error "invalid internal definition") - -and getidef e = - function - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = t } -> - begin - match find_var e s with - Some (Vsyntax f) when f == mkdefine -> Some (idpp t) - | Some (Vmacro f) -> getidef e (f e (Array.of_list (list_to_caml t))) - | _ -> None - end - | _ -> None - -and mkid e x v = - match x with - Spair { car = _; cdr = al } -> - mklambda e al (Array.of_list (list_to_caml v)) - | _ -> compile e v - -and expand_begin e = - function - (Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = t }) as x -> - begin - match find_var e s with - Some (Vsyntax f) when f == mkbegin -> - Array.concat (List.map (expand_begin e) (list_to_caml t)) - | Some (Vmacro f) -> - expand_begin e (f e (Array.of_list (list_to_caml t))) - | _ -> [| x |] - end - | x -> [| x |] - -and mkbody e args = - let args = Array.concat (List.map (expand_begin e) (Array.to_list args)) in - let n = Array.length args in - let rec loop i r = - if i < n then - begin - match getidef e args.(i) with - Some d -> loop (i + 1) (d::r) - | None -> r - end - else - r - in - let ids = Array.map (fun (s, x, v) -> let r = bind_var e s in (r, x, v)) - (Array.of_list (List.rev (loop 0 []))) in - let sets = Array.map (fun (r, x, v) -> gendef r (mkid e x v)) ids in - let nid = Array.length sets in - let rest = Array.map (fun x -> compile e x) - (Array.sub args nid (n - nid)) - in - Array.append sets rest - -and mkset e args = - if Array.length args != 2 then - raise (Error "set!: requires exactly two args"); - match args.(0) with - (Ssymbol _ | Sesym (_, _)) as s -> - let v = compile e args.(1) in - genset (get_var e s) v - | _ -> raise (Error "set!: not a symbol") - -(* Note that the first item of the "body" array is ignored, it - corresponds to the argument list but may be in the form expected - by either define or lambda. *) -and mklambda e args body = - let ne = new_frame e - and nargs = ref 0 - and has_rest = ref false in - let rec scanargs = - function - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = tl } -> - let _ = bind_var ne s in - incr nargs; - scanargs tl - | (Ssymbol _ | Sesym (_, _)) as s -> - let _ = bind_var ne s in - incr nargs; - has_rest := true; - () - | Snull -> () - | _ -> raise (Error "lambda: bad arg list") - in - scanargs args; - let body = - mkseq (mkbody ne (Array.sub body 1 (Array.length body - 1))) - in - Clambda (make_proc body !nargs !has_rest !(ne.env_frame_size)) - -and mkif e args = - match Array.length args with - 2 -> Cif (compile e args.(0), compile e args.(1), Cval Sunspec) - | 3 -> Cif (compile e args.(0), compile e args.(1), compile e args.(2)) - | _ -> raise (Error "if: needs two or three args") - -and mknamedlet e s args = - let argv = - Array.map - (letsplit (fun s v -> s, compile e v)) - (Array.of_list (list_to_caml args.(1))) in - let ar = new_var e in - let ne = new_frame e in - bind_name ne s ar; - let av = - Array.map (fun (s, v) -> let _ = bind_var ne s in v) argv in - let body = mkseq (mkbody ne (Array.sub args 2 (Array.length args - 2))) in - let proc = - Clambda (make_proc body (Array.length av) false !(ne.env_frame_size)) - in - Cseq2 (gendef ar proc, mkapply (genref ar) av) - -and mklet e args = - if Array.length args < 2 then - raise (Error "let: too few args"); - match args.(0) with - (Ssymbol _ | Sesym (_, _)) as s -> mknamedlet e s args - | Snull -> mkseq (mkbody e (Array.sub args 1 (Array.length args - 1))) - | Spair _ as al -> - let argv = - Array.map - (letsplit (fun s v -> s, compile e v)) - (Array.of_list (list_to_caml al)) in - let ne = new_frame e in - let av = Array.map (fun (s, v) -> let _ = bind_var ne s in v) argv in - let body = mkseq (mkbody ne (Array.sub args 1 (Array.length args - 1))) in - let proc = - Clambda (make_proc body (Array.length av) false !(ne.env_frame_size)) - in - mkapply proc av - | _ -> raise (Error "let: missing argument list") - -and mkletstar e args = - if Array.length args < 2 then - raise (Error "let*: too few args"); - let rec build e = - function - x::t -> - let (s, v) = letsplit (fun s v -> s, compile e v) x in - let ne = new_frame e in - let _ = bind_var ne s in - let body = build ne t in - let proc = Clambda (make_proc body 1 false !(ne.env_frame_size)) in - mkapply proc [| v |] - | [] -> mkseq (mkbody e (Array.sub args 1 (Array.length args - 1))) - in - build e (list_to_caml args.(0)) - -and mkletrec e args = - if Array.length args < 2 then - raise (Error "letrec: too few args"); - let ne = new_frame e in - let av = - Array.map (letsplit (fun s v -> let r = bind_var ne s in (r, v))) - (Array.of_list (list_to_caml args.(0))) in - let avi = Array.map (fun (r, v) -> compile ne v) av in - let ne' = new_frame ne in - let sets = Array.map (fun (r, v) -> gendef r (genref (new_var ne'))) av in - let body = mkseq (Array.append sets - (mkbody ne' (Array.sub args 1 (Array.length args - 1)))) in - let proc = - Clambda (make_proc body (Array.length av) false !(ne'.env_frame_size)) in - let proc = - Clambda (make_proc (mkapply proc avi) - (Array.length av) false !(ne.env_frame_size)) - in - mkapply proc (Array.map (fun _ -> Cval Sunspec) av) - -and compileseq e s = - mkseq (Array.map (fun x -> compile e x) - (Array.of_list (list_to_caml s))) - -and mkcond e args = - Ccond - (Array.map - (function - Spair { car = test; - cdr = Spair { car = (Ssymbol _ | Sesym (_, _)) as s; - cdr = Spair { car = x; cdr = Snull }}} - when is_keyword e s "=>" -> - (Ccondspec (compile e test), (compile e x)) - | Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = body } - when is_keyword e s "else" -> - (Cval Strue, compileseq e body) - | Spair { car = test; cdr = body } -> - (compile e test, compileseq e body) - | _ -> raise (Error "cond: syntax error")) - args) - -and mkcase e args = - Ccase - (compile e args.(0), - Array.map - (function - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = body } - when is_keyword e s "else" -> - ([| |], compileseq e body) - | Spair { car = Spair _ as c; cdr = body } -> - (Array.of_list (list_to_caml c), compileseq e body) - | _ -> raise (Error "case: syntax error")) - (Array.sub args 1 (Array.length args - 1))) - -and mkdo e args = - if Array.length args < 2 then - raise (Error "do: bad args"); - let vv = - Array.map - (dosplit (fun sym init step -> sym, compile e init, step)) - (Array.of_list (list_to_caml args.(0))) - and (test, result) = - match args.(1) with - Spair { car = t; cdr = r } -> t, r - | _ -> raise (Error "do: bad args") - and anonvar = new_var e - and ne = new_frame e in - let av = Array.map (fun (sym, init, _) -> - let _ = bind_var ne sym in init) vv in - let body = - Cif (compile ne test, compileseq ne result, - mkseq - (Array.append - (Array.map (fun x -> compile ne x) - (Array.sub args 2 (Array.length args - 2))) - [| mkapply (genref anonvar) - (Array.map (fun (_, _, step) -> compile ne step) vv) |])) - in - let proc = - Clambda (make_proc body (Array.length av) false !(ne.env_frame_size)) - in - Cseq2 (gendef anonvar proc, mkapply (genref anonvar) av) - -and mkdelay e = - function - [| expr |] -> Cdelay (compile e expr) - | _ -> raise (Error "delay: bad args") - -and mkqq e args = - if Array.length args <> 1 then - raise (Error "quasiquote: need exactly one arg") - else - let rec qq depth = - function - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; - cdr = Spair { car = x; cdr = Snull }} -> - if is_syntax e s mkqq then - Cqqp (Cval s, Cqqp (qq (depth + 1) x, Cval Snull)) - else if is_keyword e s "unquote" then - begin - if depth > 0 then - Cqqp (Cval s, Cqqp (qq (depth - 1) x, Cval Snull)) - else - compile e x - end - else if is_keyword e s "unquote-splicing" then - begin - if depth > 0 then - Cqqp (Cval s, Cqqp (qq (depth - 1) x, Cval Snull)) - else - Cqqspl (compile e x) - end - else - Cqqp (Cval s, Cqqp (qq depth x, Cval Snull)) - | Spair { car = h; cdr = t } -> Cqqp (qq depth h, qq depth t) - | Svector v -> - let qv = Array.map (fun x -> qq depth x) v in - if chksplice qv then - Cqqvs (Array.to_list qv) - else - Cqqv qv - | x -> Cval (scanquoted x) - in - qq 0 args.(0) - -and applysym e s args = - match get_var e s with - Vsyntax f -> f e args - | Vmacro f -> compile e (f e args) - | r -> mkapply (genref r) (Array.map (fun x -> compile e x) args) - -and compile e = - function - (Ssymbol _ | Sesym (_, _)) as s -> genref (get_var e s) - | Spair p -> - let args = Array.of_list (list_to_caml p.cdr) in - begin - match p.car with - (Ssymbol _ | Sesym (_, _)) as s -> applysym e s args - | x -> - mkapply (compile e x) (Array.map (fun x -> compile e x) args) - end - | x -> Cval (scanquoted x) - -and mkbegin e args = - mkseq (Array.map (fun x -> compile e x) args) -;; - -let bind_lang e = - let spec = - [ sym_define, mkdefine; - sym_set, mkset; - sym_let, mklet; - sym_letstar, mkletstar; - sym_letrec, mkletrec; - sym_if, mkif; - sym_cond, mkcond; - sym_case, mkcase; - sym_do, mkdo; - sym_begin, mkbegin; - sym_and, (fun e args -> mkand (Array.map (fun x -> compile e x) args)); - sym_or, (fun e args -> mkor (Array.map (fun x -> compile e x) args)); - sym_lambda, - (fun e args -> - if Array.length args >= 1 then - mklambda e args.(0) args - else - raise (Error "lambda: needs at least one arg")); - sym_delay, mkdelay; - sym_quote, - (fun e args -> - if Array.length args = 1 then - Cval (scanquoted args.(0)) - else - raise (Error "quote: need exactly one arg")); - sym_quasiquote, mkqq ] - in - List.iter (fun (s, f) -> bind_name e s (Vsyntax f)) spec; - bind_name e sym_else (Vkeyword "else"); - bind_name e sym_arrow (Vkeyword "=>"); - bind_name e sym_unquote (Vkeyword "unquote"); - bind_name e sym_unquote_splicing (Vkeyword "unquote-splicing"); - bind_name e sym_syntax_rules (Vkeyword "syntax-rules"); -;; - diff --git a/ocs-1.0.3/src/ocs_compile.mli b/ocs-1.0.3/src/ocs_compile.mli deleted file mode 100644 index 1333149..0000000 --- a/ocs-1.0.3/src/ocs_compile.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* Compile expressions *) - -open Ocs_types - -val compile : env -> sval -> code - -val bind_lang : env -> unit - -(* Internal, used by ocs_macro *) -val letsplit : (sval -> sval -> 'a) -> sval -> 'a -val mkseq : code array -> code -val mkbody : env -> sval array -> code array - diff --git a/ocs-1.0.3/src/ocs_complex.ml b/ocs-1.0.3/src/ocs_complex.ml deleted file mode 100644 index 8572a50..0000000 --- a/ocs-1.0.3/src/ocs_complex.ml +++ /dev/null @@ -1,44 +0,0 @@ -(* Implement functions missing from Complex. *) - -open Complex - -let sin_cplx z = - { re = sin z.re *. cosh z.im; - im = cos z.re *. sinh z.im } -;; - -let cos_cplx z = - { re = cos z.re *. cosh z.im; - im = -.(sin z.re) *. sinh z.im } -;; - -let tan_cplx z = - div (sin_cplx z) (cos_cplx z) -;; - -(* asin z = -i Ln (iz + sqrt (1 - z^2)) *) - -let asin_cplx = - function { re = x; im = y } -> - let t = sqrt { re = 1.0 +. y *. y -. x *. x; im = -2.0 *. x *. y } in - let z = log { re = t.re -. y; im = t.im +. x } in - { re = z.im; im = -.z.re } -;; - -(* acos z = pi/2 - asin z *) - -let acos_cplx z = - match asin_cplx z with - { re = x; im = y } -> { re = 1.57079632679489661923 -. x; im = -.y } -;; - -(* atan z = [Ln (1 + iz) - Ln (1 - iz)] / 2i *) - -let atan_cplx = - function { re = x; im = y } -> - let t1 = log { re = 1.0 -. y; im = x } - and t2 = log { re = 1.0 +. y; im = -.x } in - { re = (t1.im -. t2.im) *. 0.5; - im = -.(t1.re -. t2.re) *. 0.5 } -;; - diff --git a/ocs-1.0.3/src/ocs_complex.mli b/ocs-1.0.3/src/ocs_complex.mli deleted file mode 100644 index b8f48bd..0000000 --- a/ocs-1.0.3/src/ocs_complex.mli +++ /dev/null @@ -1,11 +0,0 @@ -(* Functions missing from Complex. *) - -open Complex - -val sin_cplx : t -> t -val cos_cplx : t -> t -val tan_cplx : t -> t -val asin_cplx : t -> t -val acos_cplx : t -> t -val atan_cplx : t -> t - diff --git a/ocs-1.0.3/src/ocs_contin.ml b/ocs-1.0.3/src/ocs_contin.ml deleted file mode 100644 index 118b36e..0000000 --- a/ocs-1.0.3/src/ocs_contin.ml +++ /dev/null @@ -1,114 +0,0 @@ -(* Continuations *) - -open Ocs_types -open Ocs_error -open Ocs_eval -open Ocs_env -open Ocs_misc - -let rec find_depth fdx tdx al bl = - match (fdx, tdx) with - (Some f, Some t) -> - if f.dynext_parent == t.dynext_parent then - (List.rev (f.dynext_after::al), t.dynext_before::bl) - else if f.dynext_depth > t.dynext_depth then - find_depth f.dynext_parent tdx (f.dynext_after::al) bl - else if f.dynext_depth < t.dynext_depth then - find_depth fdx t.dynext_parent al (t.dynext_before::bl) - else - find_depth f.dynext_parent t.dynext_parent - (f.dynext_after::al) (t.dynext_before::bl) - | (Some f, None) -> - find_depth f.dynext_parent tdx (f.dynext_after::al) bl - | (None, Some t) -> - find_depth fdx t.dynext_parent al (t.dynext_before::bl) - | _ -> (List.rev al, bl) -;; - -(* Change from the dynamic extent fdx to the dynamic extent tdx *) -let dxswitch fdx tdx cont = - if fdx == tdx then - cont () - else - let (al, bl) = find_depth fdx tdx [] [] in - let rec bloop = - function - [] -> cont () - | h::t -> eval (fst h) (fun _ -> bloop t) (snd h) - in - let rec aloop = - function - [] -> bloop bl - | h::t -> eval (fst h) (fun _ -> aloop t) (snd h) - in - aloop al -;; - -let continuation dx cc th _ = - function - [| x |] -> dxswitch th.th_dynext dx (fun () -> cc x) - | av -> dxswitch th.th_dynext dx (fun () -> cc (Svalues av)) -;; - -let call_cc th cc = - function - [| proc |] -> - let cont = - Sprim { prim_fun = Pfcn (continuation th.th_dynext cc); - prim_name = "" } - in - eval th cc (Capply1 (Cval proc, Cval cont)) - | _ -> raise (Error "call/cc: bad args") -;; - -let values = - function - [| x |] -> x - | av -> Svalues av -;; - -let call_values th cc = - function - [| producer; consumer |] -> - eval th - (function - Svalues av -> - eval th cc (mkapply (Cval consumer) - (Array.map (fun x -> Cval x) av)) - | x -> eval th cc (Capply1 (Cval consumer, Cval x))) - (Capply0 (Cval producer)) - | _ -> raise (Error "call-with-values: bad args") -;; - -let dynamic_wind th cc = - function - [| before; thunk; after |] -> - let before = Capply0 (Cval before) - and after = Capply0 (Cval after) in - let ndx = { - dynext_parent = th.th_dynext; - dynext_depth = - (match th.th_dynext with - None -> 0 - | Some dx -> dx.dynext_depth + 1); - dynext_before = (th, before); - dynext_after = (th, after) - } in - eval th - (fun _ -> - eval { th with th_dynext = Some ndx } - (fun r -> - eval th (fun _ -> cc r) after) (Capply0 (Cval thunk))) before - | _ -> raise (Error "dynamic-wind: bad args") -;; - -let init e = - set_pfcn e call_cc "call-with-current-continuation"; - set_pfcn e call_cc "call/cc"; - - set_pfn e values "values"; - - set_pfcn e call_values "call-with-values"; - set_pfcn e dynamic_wind "dynamic-wind"; -;; - diff --git a/ocs-1.0.3/src/ocs_contin.mli b/ocs-1.0.3/src/ocs_contin.mli deleted file mode 100644 index 6f25bd3..0000000 --- a/ocs-1.0.3/src/ocs_contin.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* Continuations *) - -open Ocs_types - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_env.ml b/ocs-1.0.3/src/ocs_env.ml deleted file mode 100644 index 0e7eae4..0000000 --- a/ocs-1.0.3/src/ocs_env.ml +++ /dev/null @@ -1,143 +0,0 @@ -(* Compilation environment, variable bindings. *) - -open Ocs_types -open Ocs_error -open Ocs_sym -open Ocs_vartable - -let top_env () = - { env_depth = -1; - env_vartable = vt_create (); - env_frame_size = ref 0; - env_tagged = [] } -;; - -let new_scope e = - { env_depth = e.env_depth; - env_vartable = vt_inherit e.env_vartable; - env_frame_size = e.env_frame_size; - env_tagged = e.env_tagged } -;; - -let new_frame e = - { env_depth = e.env_depth + 1; - env_vartable = vt_inherit e.env_vartable; - env_frame_size = ref 0; - env_tagged = e.env_tagged } -;; - -let new_var e = - if e.env_depth < 0 then - Vglob { g_sym = Snull; g_val = Sunbound } - else - let v = Vloc (e.env_depth, !(e.env_frame_size)) in - incr e.env_frame_size; - v -;; - -let bind_name e sym v = - match sym with - Sesym (te, sym) -> - e.env_tagged <- (te, sym, v)::e.env_tagged - | _ -> - begin - match v with - Vglob g -> g.g_sym <- sym - | _ -> () - end; - var_insert e.env_vartable (sym_name sym) v -;; - -let bind_var e sym = - let r = new_var e in - bind_name e sym r; - r -;; - -let find_tagged te ts l = - let rec loop = - function - (e, s, v)::t -> - if e == te && s == ts then - Some v - else - loop t - | [] -> None - in - loop l -;; - -let rec find_var e sym = - match sym with - Sesym (te, sym) -> - begin - match find_tagged te sym e.env_tagged with - Some _ as v -> v - | None -> find_var te sym - end - | _ -> var_find e.env_vartable (sym_name sym) -;; - -let rec get_var e sym = - match sym with - Sesym (te, sym) -> - begin - match find_tagged te sym e.env_tagged with - Some v -> v - | None -> get_var te sym - end - | _ -> var_get e.env_vartable (sym_name sym) - (fun () -> Vglob { g_sym = sym; g_val = Sunbound }) -;; - -let set_glob e sym v = - match get_var e sym with - Vglob g -> g.g_val <- v - | _ -> raise (Error "set_glob: not a global") -;; - -let vb_copy = - function - Vglob g -> Vglob { g with g_val = g.g_val } - | x -> x - -let env_copy e = - { e with - env_vartable = vt_copy e.env_vartable vb_copy; - env_tagged = [] } - -let is_a_keyword e sym = - match find_var e sym with - Some (Vkeyword _) -> true - | _ -> false -;; - -let is_keyword e sym name = - match find_var e sym with - Some (Vkeyword kw) -> kw = name - | _ -> false -;; - -let safe_is_keyword e sym name = - match sym with - Ssymbol _ | Sesym (_, _) -> is_keyword e sym name - | _ -> false -;; - -let is_syntax e sym sf = - match find_var e sym with - Some (Vsyntax f) -> f == sf - | _ -> false -;; - -let set_pfg e f n = - set_glob e (get_symbol n) (Sprim { prim_fun = f; prim_name = n }) -;; - -let set_pf0 e f n = set_pfg e (Pf0 f) n -let set_pf1 e f n = set_pfg e (Pf1 f) n -let set_pf2 e f n = set_pfg e (Pf2 f) n -let set_pf3 e f n = set_pfg e (Pf3 f) n -let set_pfn e f n = set_pfg e (Pfn f) n -let set_pfcn e f n = set_pfg e (Pfcn f) n - diff --git a/ocs-1.0.3/src/ocs_env.mli b/ocs-1.0.3/src/ocs_env.mli deleted file mode 100644 index e84c55b..0000000 --- a/ocs-1.0.3/src/ocs_env.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Compilation environment, variable bindings. *) - -open Ocs_types -open Ocs_sym - -val top_env : unit -> env -val new_scope : env -> env -val new_frame : env -> env -val new_var : env -> vbind -val bind_name : env -> sval -> vbind -> unit -val bind_var : env -> sval -> vbind -val find_var : env -> sval -> vbind option -val get_var : env -> sval -> vbind -val set_glob : env -> sval -> sval -> unit -val env_copy : env -> env - -val is_a_keyword : env -> sval -> bool -val is_keyword : env -> sval -> string -> bool -val safe_is_keyword : env -> sval -> string -> bool - -val is_syntax : env -> sval -> (env -> sval array -> code) -> bool - -val set_pf0 : env -> (unit -> sval) -> string -> unit -val set_pf1 : env -> (sval -> sval) -> string -> unit -val set_pf2 : env -> (sval -> sval -> sval) -> string -> unit -val set_pf3 : env -> (sval -> sval -> sval -> sval) -> string -> unit -val set_pfn : env -> (sval array -> sval) -> string -> unit -val set_pfcn : - env -> (thread -> (sval -> unit) -> sval array -> unit) -> string -> unit - diff --git a/ocs-1.0.3/src/ocs_error.ml b/ocs-1.0.3/src/ocs_error.ml deleted file mode 100644 index bbed9a8..0000000 --- a/ocs-1.0.3/src/ocs_error.ml +++ /dev/null @@ -1,11 +0,0 @@ -(* Errors (exceptions) generated by the library. *) - -(* Source location (file, line) *) -type location = - string * int - -(* These errors indicate non-fatal run-time errors that should be - reported, generally interactively. *) -exception Error of string -exception ErrorL of location * string - diff --git a/ocs-1.0.3/src/ocs_eval.ml b/ocs-1.0.3/src/ocs_eval.ml deleted file mode 100644 index 2681dd0..0000000 --- a/ocs-1.0.3/src/ocs_eval.ml +++ /dev/null @@ -1,339 +0,0 @@ -(* Actual evaluator for the semi-compiled form. *) - -open Ocs_types -open Ocs_error -open Ocs_sym -open Ocs_misc - -(* Local variables are stored either in th_frame or th_display. - th_frame is the deepest frame, not yet part of the display. *) - -let getl th d i = - if d >= Array.length th.th_display then - th.th_frame.(i) - else - th.th_display.(d).(i) -;; - -let setl th d i v = - if d >= Array.length th.th_display then - th.th_frame.(i) <- v - else - th.th_display.(d).(i) <- v -;; - -let args_err p n = - if p.proc_has_rest then - Printf.sprintf "procedure %s expected %d or more args got %d" - p.proc_name (p.proc_nargs - 1) n - else - Printf.sprintf "procedure %s expected %d args got %d" - p.proc_name p.proc_nargs n - -let chkargs p n = - match p with - Sproc (p, _) -> - if n <> p.proc_nargs && (not p.proc_has_rest || n < p.proc_nargs - 1) then - raise (Error (args_err p n)) - else - () - | Sprim p -> - if - begin - match p.prim_fun with - Pf0 _ -> n = 0 - | Pf1 _ -> n = 1 - | Pf2 _ -> n = 2 - | Pf3 _ -> n = 3 - | Pfn _ | Pfcn _ -> true - end - then - () - else - raise (Error (p.prim_name ^ ": wrong number of arguments")) - | _ -> raise (Error "apply: not a procedure or primitive") -;; - -let rec doapply th cc p disp av = - let th = { - th with - th_frame = Array.make p.proc_frame_size Seof; - th_display = disp; - th_depth = Array.length disp } - in - if p.proc_has_rest then - begin - let nfixed = p.proc_nargs - 1 - and n = Array.length av in - if nfixed > 0 then - Array.blit av 0 th.th_frame 0 nfixed; - let rec mkrest i r = - if i < nfixed then r - else mkrest (i - 1) (Spair { car = av.(i); cdr = r }) - in - th.th_frame.(nfixed) <- mkrest (n - 1) Snull - end - else - Array.blit av 0 th.th_frame 0 p.proc_nargs; - eval th cc p.proc_body - -and eval th cc = - function - Cval v -> cc v - | Cseq2 (s1, s2) -> - eval th (fun _ -> eval th cc s2) s1 - | Cseq3 (s1, s2, s3) -> - eval th (fun _ -> eval th (fun _ -> eval th cc s3) s2) s1 - | Cseqn s -> - let n = Array.length s in - let rec loop i = - if i = n - 1 then - eval th cc s.(i) - else - eval th (fun _ -> loop (i + 1)) s.(i) - in - loop 0 - | Cand2 (s1, s2) -> - eval th (function Sfalse -> cc Sfalse | _ -> eval th cc s2) s1 - | Cand3 (s1, s2, s3) -> - eval th - (function - Sfalse -> cc Sfalse - | _ -> - eval th - (function - Sfalse -> cc Sfalse - | _ -> eval th cc s3) s2) s1 - | Candn s -> - let n = Array.length s in - let rec loop i = - begin - if i = n - 1 then - eval th cc s.(i) - else - eval th (function Sfalse -> cc Sfalse | _ -> loop (i + 1)) s.(i) - end - in - loop 0 - | Cor2 (s1, s2) -> - eval th (function Sfalse -> eval th cc s2 | x -> cc x) s1 - | Cor3 (s1, s2, s3) -> - eval th - (function - Sfalse -> eval th - (function - Sfalse -> eval th cc s3 - | x -> cc x) s2 - | x -> cc x) s1 - | Corn s -> - let n = Array.length s in - let rec loop i = - if i = n - 1 then - eval th cc s.(i) - else - eval th (function Sfalse -> loop (i + 1) | x -> cc x) s.(i) - in - loop 0 - | Cif (c, tx, fx) -> - eval th - (function Sfalse -> eval th cc fx | _ -> eval th cc tx) - c - | Csetg (g, c) -> - eval th (fun v -> - if g.g_val == Sunbound then - raise (Error ("set!: unbound variable: " ^ (sym_name g.g_sym))) - else - g.g_val <- v; cc Sunspec) c - | Csetl (d, i, c) -> - eval th (fun v -> setl th d i v; cc Sunspec) c - | Cdefine (g, c) -> - eval th (fun v -> g.g_val <- v; cc Sunspec) c - | Cgetg g -> - if g.g_val == Sunbound then - raise (Error ("unbound variable: " ^ (sym_name g.g_sym))) - else - cc g.g_val - | Cgetl (d, i) -> cc (getl th d i) - | Capply0 c -> - eval th (fun cv -> - chkargs cv 0; - match cv with - Sproc (p, d) -> doapply th cc p d [| |] - | Sprim p -> - begin - match p.prim_fun with - Pf0 f -> cc (f ()) - | Pfn f -> cc (f [| |]) - | Pfcn f -> f th cc [| |] - | _ -> assert false - end - | _ -> assert false) c - | Capply1 (c, a1) -> - eval th (fun cv -> eval th (fun a1v -> - chkargs cv 1; - match cv with - Sproc (p, d) -> doapply th cc p d [| a1v |] - | Sprim p -> - begin - match p.prim_fun with - Pf1 f -> cc (f a1v) - | Pfn f -> cc (f [| a1v |]) - | Pfcn f -> f th cc [| a1v |] - | _ -> assert false - end - | _ -> assert false) a1) c - | Capply2 (c, a1, a2) -> - eval th (fun cv -> eval th (fun a1v -> eval th (fun a2v -> - chkargs cv 2; - match cv with - Sproc (p, d) -> doapply th cc p d [| a1v; a2v |] - | Sprim p -> - begin - match p.prim_fun with - Pf2 f -> cc (f a1v a2v) - | Pfn f -> cc (f [| a1v; a2v |]) - | Pfcn f -> f th cc [| a1v; a2v |] - | _ -> assert false - end - | _ -> assert false) a2) a1) c - | Capply3 (c, a1, a2, a3) -> - eval th (fun cv -> eval th (fun a1v -> eval th (fun a2v -> - eval th (fun a3v -> - chkargs cv 3; - match cv with - Sproc (p, d) -> doapply th cc p d [| a1v; a2v; a3v |] - | Sprim p -> - begin - match p.prim_fun with - Pf3 f -> cc (f a1v a2v a3v) - | Pfn f -> cc (f [| a1v; a2v; a3v |]) - | Pfcn f -> f th cc [| a1v; a2v; a3v |] - | _ -> assert false - end - | _ -> assert false) a3) a2) a1) c - | Capplyn (c, a) -> - eval th (fun cv -> - let n = Array.length a in - let av = Array.make n Snull in - let rec loop i = - if i = n then - begin - chkargs cv n; - match cv with - Sproc (p, d) -> doapply th cc p d av - | Sprim p -> - begin - match p.prim_fun with - Pfn f -> cc (f av) - | Pfcn f -> f th cc av - | _ -> assert false - end - | _ -> assert false - end - else - eval th (fun x -> av.(i) <- x; loop (i + 1)) a.(i) - in - loop 0) c - | Clambda p -> - let n = th.th_depth + 1 in - let nd = Array.init n - (fun i -> if i < n - 1 then th.th_display.(i) - else th.th_frame) - in - cc (Sproc (p, nd)) - | Cqqp (h, t) -> - begin - match h with - Cqqspl x -> - eval th (fun usl -> eval th (fun t -> - let rec findtl = - function - Spair ({ car = _; cdr = Snull } as p) -> - p.cdr <- t; usl - | Spair { car = _; cdr = nt } -> findtl nt - | Snull -> t - | _ -> raise (Error "unquote-splicing: not a list") - in - cc (findtl usl)) t) x - | _ -> - eval th (fun h -> eval th (fun t -> - cc (Spair { car = h; cdr = t })) t) h - end - | Cqqv v -> - let n = Array.length v in - let qv = Array.make n Snull in - let rec loop i = - if i = n then - cc (Svector qv) - else - eval th (fun x -> qv.(i) <- x; loop (i + 1)) v.(i) - in - loop 0 - | Cqqvs l -> - begin - let rec loop r = - function - [] -> cc (Svector (Array.of_list r)) - | (Cqqspl x)::t -> - eval th (fun l -> loop ((list_to_caml l) @ r) t) x - | h::t -> - eval th (fun x -> loop (x::r) t) h - in - loop [] (List.rev l) - end - | Cqqspl x -> raise (Error "unquote-splicing: not valid here") - | Ccond av -> - begin - let n = Array.length av in - let rec loop i = - if i < n then - begin - match av.(i) with - (Ccondspec c, b) -> - eval th (fun v -> - if v <> Sfalse then eval th cc (Capply1 (b, Cval v)) - else loop (i + 1)) c - | (c, b) -> - eval th (fun v -> - if v <> Sfalse then eval th cc b - else loop (i + 1)) c - end - else - cc Sunspec - in - loop 0 - end - | Ccase (c, m) -> - eval th (fun v -> - let n = Array.length m in - let rec loop i = - if i < n then - begin - match m.(i) with - ([| |], b) -> eval th cc b - | (mv, b) -> - let n = Array.length mv in - let rec has i = - if i < n then - begin - let mvv = mv.(i) in - if mvv == v || test_eqv mvv v then true - else has (i + 1) - end - else - false - in - if has 0 then eval th cc b - else loop (i + 1) - end - else - cc Sunspec - in - loop 0) c - | Cdelay c -> - cc (Spromise { promise_code = c; - promise_val = None; - promise_th = Some { th with th_frame = th.th_frame } }) - | _ -> raise (Error "eval: internal error") -;; - diff --git a/ocs-1.0.3/src/ocs_eval.mli b/ocs-1.0.3/src/ocs_eval.mli deleted file mode 100644 index 10f9259..0000000 --- a/ocs-1.0.3/src/ocs_eval.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* Evaluation *) - -open Ocs_types - -val eval : thread -> (sval -> unit) -> code -> unit - diff --git a/ocs-1.0.3/src/ocs_io.ml b/ocs-1.0.3/src/ocs_io.ml deleted file mode 100644 index 06fc612..0000000 --- a/ocs-1.0.3/src/ocs_io.ml +++ /dev/null @@ -1,224 +0,0 @@ -(* I/O primitives. *) - -open Ocs_types -open Ocs_error -open Ocs_env -open Ocs_eval -open Ocs_print - -let get_stdin th = - match th.th_stdin with - Sport p -> p - | _ -> assert false -;; - -let get_stdout th = - match th.th_stdout with - Sport p -> p - | _ -> assert false -;; - -let read th cc = - function - [| |] -> - cc (Ocs_read.read_from_port (get_stdin th)) - | [| Sport port |] -> cc (Ocs_read.read_from_port port) - | _ -> raise (Error "read: bad args") -;; - -let rdchr p cc = - match Ocs_port.getc p with - Some c -> cc (Schar c) - | None -> cc Seof -;; - -let read_char th cc = - function - [| |] -> rdchr (get_stdin th) cc - | [| Sport port |] -> rdchr port cc - | _ -> raise (Error "read-char: bad args") -;; - -let peekchr p cc = - match Ocs_port.getc p with - Some c -> - Ocs_port.ungetc p c; - cc (Schar c) - | None -> cc Seof -;; - -let peek_char th cc = - function - [| |] -> peekchr (get_stdin th) cc - | [| Sport port |] -> peekchr port cc - | _ -> raise (Error "peek-char: bad args") -;; - -let eof_object = - function - Seof -> Strue - | _ -> Sfalse -;; - -let chrdy p cc = - cc (if Ocs_port.char_ready p then Strue else Sfalse) -;; - -let char_ready th cc = - function - [| |] -> chrdy (get_stdin th) cc - | [| Sport port |] -> chrdy port cc - | _ -> raise (Error "char-ready?: bad args") -;; - -let display th cc = - function - [| obj |] -> - let p = get_stdout th in print p true obj; Ocs_port.flush p; cc Sunspec - | [| obj; Sport p |] -> print p true obj; Ocs_port.flush p; cc Sunspec - | _ -> raise (Error "display: bad args") -;; - -let write th cc = - function - [| obj |] -> - let p = get_stdout th in print p false obj; Ocs_port.flush p; cc Sunspec - | [| obj; Sport p |] -> print p false obj; Ocs_port.flush p; cc Sunspec - | _ -> raise (Error "write: bad args") -;; - -let write_char th cc = - function - [| Schar c |] -> - let p = get_stdout th in Ocs_port.putc p c; Ocs_port.flush p; cc Sunspec - | [| Schar c; Sport p |] -> Ocs_port.putc p c; Ocs_port.flush p; cc Sunspec - | _ -> raise (Error "write-char: bad args") -;; - -let newline th cc = - function - [| |] -> - let p = get_stdout th in Ocs_port.putc p '\n'; Ocs_port.flush p; cc Sunspec - | [| Sport p |] -> Ocs_port.putc p '\n'; Ocs_port.flush p; cc Sunspec - | _ -> raise (Error "newline: bad args") -;; - -let current_input th cc = - function - [| |] -> cc th.th_stdin - | _ -> raise (Error "current-input-port: bad args") -;; - -let current_output th cc = - function - [| |] -> cc th.th_stdout - | _ -> raise (Error "current-output-port: bad args") -;; - -let is_input = - function - Sport p -> if Ocs_port.is_input p then Strue else Sfalse - | _ -> Sfalse -;; - -let is_output = - function - Sport p -> if Ocs_port.is_output p then Strue else Sfalse - | _ -> Sfalse -;; - -let open_input_file = - function - Sstring s -> Sport (Ocs_port.open_input_port s) - | _ -> raise (Error "expected string as input file name") -;; - -let open_output_file = - function - Sstring s -> Sport (Ocs_port.open_output_port s) - | _ -> raise (Error "expected string as output file name") -;; - -let close_port = - function - Sport p -> Ocs_port.close p - | _ -> raise (Error "close-port: invalid argument") -;; - -let scm_close_port p = - close_port p; Sunspec -;; - -(* Note that the call-with-*-file functions close the port if the - procedure exits, so they must not be re-called using a captured - continuation after they exit once. Dynamic extents can't be used - for this because closing and reopening the file would be an even - bigger problem. *) - -let call_w_in th cc = - function - [| name; proc |] -> - let p = open_input_file name in - eval th (fun x -> close_port p; cc x) (Capply1 (Cval proc, Cval p)) - | _ -> raise (Error "call-with-input-file: bad args") -;; - -let call_w_out th cc = - function - [| name; proc |] -> - let p = open_output_file name in - eval th (fun x -> close_port p; cc x) (Capply1 (Cval proc, Cval p)) - | _ -> raise (Error "call-with-output-file: bad args") -;; - -let w_in th cc = - function - [| name; thunk |] -> - let p = open_input_file name in - eval { th with th_stdin = p } - (fun x -> close_port p; cc x) - (Capply0 (Cval thunk)) - | _ -> raise (Error "with-input-from-file: bad args") -;; - -let w_out th cc = - function - [| name; thunk |] -> - let p = open_output_file name in - eval { th with th_stdout = p } - (fun x -> close_port p; cc x) - (Capply0 (Cval thunk)) - | _ -> raise (Error "with-output-to-file: bad args") -;; - -let init e = - set_pfcn e read "read"; - set_pfcn e read_char "read-char"; - set_pfcn e peek_char "peek-char"; - set_pfcn e char_ready "char-ready?"; - - set_pf1 e eof_object "eof-object?"; - - set_pfcn e display "display"; - set_pfcn e newline "newline"; - set_pfcn e write "write"; - set_pfcn e write_char "write-char"; - - set_pfcn e current_input "current-input-port"; - set_pfcn e current_output "current-output-port"; - - set_pf1 e is_input "input-port?"; - set_pf1 e is_output "output-port?"; - - set_pf1 e open_input_file "open-input-file"; - set_pf1 e open_output_file "open-output-file"; - - set_pf1 e scm_close_port "close-input-port"; - set_pf1 e scm_close_port "close-output-port"; - - set_pfcn e call_w_in "call-with-input-file"; - set_pfcn e call_w_out "call-with-output-file"; - - set_pfcn e w_in "with-input-from-file"; - set_pfcn e w_out "with-output-to-file"; -;; diff --git a/ocs-1.0.3/src/ocs_io.mli b/ocs-1.0.3/src/ocs_io.mli deleted file mode 100644 index 0398a99..0000000 --- a/ocs-1.0.3/src/ocs_io.mli +++ /dev/null @@ -1,11 +0,0 @@ -(* I/O primitives *) - -open Ocs_types - -val read : thread -> (sval -> unit) -> sval array -> unit - -val open_input_file : sval -> sval -val open_output_file : sval -> sval - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_lex.ml b/ocs-1.0.3/src/ocs_lex.ml deleted file mode 100644 index d4796ec..0000000 --- a/ocs-1.0.3/src/ocs_lex.ml +++ /dev/null @@ -1,279 +0,0 @@ -(* Lexer for Scheme. *) - -open Ocs_types -open Ocs_error - -type token = - Leof - | Lopenv (* #( *) - | Lunqsplice (* ,@ *) - | Lident of string - | Lstring of string - | Lnumber of sval - | Lbool of sval - | Lchar of sval - | Ltoken of char - -type lexer = { - l_port : Ocs_port.port; - l_buf : Buffer.t; - l_name : string; - mutable l_line : int -} - -let make_lexer port name = - { l_port = port; - l_buf = Buffer.create 512; - l_name = name; - l_line = 0 } -;; - -let get_loc lex = - (lex.l_name, lex.l_line) -;; - -let lex_error lex err = - if String.length lex.l_name = 0 then - Error err - else - ErrorL (get_loc lex, err) -;; - -let num_w_base lex s = - let base = - match s.[0] with - 'B' | 'b' -> 2 - | 'D' | 'd' -> 10 - | 'O' | 'o' -> 8 - | 'X' | 'x' -> 16 - | _ -> raise (lex_error lex "invalid character literal") - and n = String.length s - in - let rec scn v i = - if i >= n then v - else - match s.[i] with - '0' .. '9' as c when (int_of_char c) - (int_of_char '0') < base -> - scn (v * base + (int_of_char c) - (int_of_char '0')) (i + 1) - | 'a' .. 'f' as c when base = 16 -> - scn (v * base + (int_of_char c) - (int_of_char 'a') + 10) (i + 1) - | 'A' .. 'F' as c when base = 16 -> - scn (v * base + (int_of_char c) - (int_of_char 'A') + 10) (i + 1) - | _ -> v (* Ignore trailing junk *) - in - scn 0 1 -;; - -let string_num_esc lex base n = - let rec scn v i = - if i >= n then char_of_int v - else - match Ocs_port.getc lex.l_port with - Some ('0' .. '9' as c) when - (int_of_char c) - (int_of_char '0') < base -> - scn (v * base + (int_of_char c) - (int_of_char '0')) (i + 1) - | Some ('a' .. 'f' as c) when base = 16 -> - scn (v * base + (int_of_char c) - (int_of_char 'a') + 10) (i + 1) - | Some ('A' .. 'F' as c) when base = 16 -> - scn (v * base + (int_of_char c) - (int_of_char 'A') + 10) (i + 1) - | Some c -> - Ocs_port.ungetc lex.l_port c; - char_of_int v - | None -> raise (lex_error lex "unexpected eof in string literal") - in - scn 0 0 -;; - -let read_char lex = - begin - match Ocs_port.getc lex.l_port with - Some c -> Buffer.add_char lex.l_buf c - | None -> raise (lex_error lex "unexpected eof") - end; - let rec loop () = - match Ocs_port.getc lex.l_port with - Some (('a' .. 'z' | 'A' .. 'Z' | '0' .. '9') as c) -> - Buffer.add_char lex.l_buf c; loop () - | Some c -> Ocs_port.ungetc lex.l_port c - | None -> () - in - loop (); - let s = Buffer.contents lex.l_buf in - if String.length s = 1 then - Lchar (Schar s.[0]) - else - match Ocs_char.name_to_char s with - Some c -> Lchar (Schar c) - | None -> Lchar (Schar (char_of_int (num_w_base lex s))) -;; - -let rec read_string lex = - match Ocs_port.getc lex.l_port with - Some '\"' -> Lstring (Buffer.contents lex.l_buf) - | Some '\\' -> - begin - match Ocs_port.getc lex.l_port with - Some ('N' | 'n') -> - Buffer.add_char lex.l_buf '\n'; - read_string lex - | Some ('R' | 'r') -> - Buffer.add_char lex.l_buf '\r'; - read_string lex - | Some ('T' | 't') -> - Buffer.add_char lex.l_buf '\t'; - read_string lex - | Some ('B' | 'b') -> - Buffer.add_char lex.l_buf (string_num_esc lex 2 8); - read_string lex - | Some ('D' | 'd') -> - Buffer.add_char lex.l_buf (string_num_esc lex 10 3); - read_string lex - | Some ('O' | 'o') -> - Buffer.add_char lex.l_buf (string_num_esc lex 8 3); - read_string lex - | Some ('X' | 'x') -> - Buffer.add_char lex.l_buf (string_num_esc lex 16 2); - read_string lex - | Some ('0' .. '9' as c) -> - Ocs_port.ungetc lex.l_port c; - Buffer.add_char lex.l_buf (string_num_esc lex 10 3); - read_string lex - | Some c -> - Buffer.add_char lex.l_buf c; - read_string lex - | None -> - raise (lex_error lex "unexpected eof in string literal") - end - | Some '\n' -> - lex.l_line <- lex.l_line + 1; - Buffer.add_char lex.l_buf '\n'; - read_string lex - | Some c -> - Buffer.add_char lex.l_buf c; - read_string lex - | None -> raise (lex_error lex "unexpected eof in string literal") -;; - -let rec read_ident lex = - match Ocs_port.getc lex.l_port with - Some (('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '!' | '$' | '%' | '&' | - '*' | '/' | ':' | '<' | '=' | '>' | '?' | '^' | '_' | '~' | - '+' | '-' | '.' | '@') as c) -> - Buffer.add_char lex.l_buf c; - read_ident lex - | Some c -> - Ocs_port.ungetc lex.l_port c; - Lident (Buffer.contents lex.l_buf) - | None -> - Lident (Buffer.contents lex.l_buf) -;; - -let parse_number lex = - try - Lnumber (Ocs_numstr.string_to_num (Buffer.contents lex.l_buf) 0) - with - Error err -> raise (lex_error lex err) -;; - -(* When reading numbers, accept almost any characters that look - like they may be part of a number. Some extremely obfuscated - inputs may be misinterpreted. *) -let rec read_number lex = - match Ocs_port.getc lex.l_port with - Some (('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-' | '+' | '.' | - '#' | '/' | '@') as c) -> - Buffer.add_char lex.l_buf c; - read_number lex - | Some c -> - Ocs_port.ungetc lex.l_port c; - parse_number lex - | None -> - parse_number lex -;; - -let rec tok lex = - match Ocs_port.getc lex.l_port with - Some c -> - begin - match c with - '\n' -> lex.l_line <- lex.l_line + 1; tok lex - | ' ' | '\t' | '\r' | '\012' -> tok lex - | ';' -> - begin - let rec loop () = - match Ocs_port.getc lex.l_port with - Some '\n' -> lex.l_line <- lex.l_line + 1; tok lex - | Some _ -> loop () - | None -> Leof - in - loop () - end - | ',' -> - begin - match Ocs_port.getc lex.l_port with - Some '@' -> Lunqsplice - | Some c -> Ocs_port.ungetc lex.l_port c; Ltoken ',' - | None -> Ltoken ',' - end - | '#' -> - begin - match Ocs_port.getc lex.l_port with - Some ('f' | 'F') -> Lbool Sfalse - | Some ('t' | 'T') -> Lbool Strue - | Some (('B' | 'b' | 'D' | 'd' | 'O' | 'o' | 'X' | 'x' | - 'E' | 'e' | 'I' | 'i') as c) -> - Buffer.add_char lex.l_buf '#'; - Buffer.add_char lex.l_buf c; - read_number lex - | Some '\\' -> read_char lex - | Some '(' -> Lopenv - | Some c -> Ocs_port.ungetc lex.l_port c; Ltoken '#' - | None -> Ltoken '#' - end - | '\"' -> read_string lex - | '+' | '-' -> - begin - match Ocs_port.getc lex.l_port with - Some (('0' .. '9' | 'i' | 'I' | '.') as x) -> - Buffer.add_char lex.l_buf c; - Buffer.add_char lex.l_buf x; - read_number lex - | Some x -> - Ocs_port.ungetc lex.l_port x; - Lident (String.make 1 c) - | None -> Lident (String.make 1 c) - end - | '.' -> - begin - match Ocs_port.getc lex.l_port with - Some '.' -> - Buffer.add_string lex.l_buf ".."; - read_ident lex - | Some ('0' .. '9' as c) -> - Buffer.add_char lex.l_buf '.'; - Buffer.add_char lex.l_buf c; - read_number lex - | Some c -> - Ocs_port.ungetc lex.l_port c; - Ltoken '.' - | None -> Ltoken '.' - end - | '0' .. '9' -> - Buffer.add_char lex.l_buf c; - read_number lex - | 'a' .. 'z' | 'A' .. 'Z' | '!' | '$' | '%' | '&' | '*' | '/' - | ':' | '<' | '=' | '>' | '?' | '^' | '_' | '~' -> - begin - Buffer.add_char lex.l_buf c; - read_ident lex - end - | _ -> Ltoken c - end - | None -> Leof -;; - -let get_tok lex = - Buffer.clear lex.l_buf; - tok lex -;; - diff --git a/ocs-1.0.3/src/ocs_lex.mli b/ocs-1.0.3/src/ocs_lex.mli deleted file mode 100644 index 55892ac..0000000 --- a/ocs-1.0.3/src/ocs_lex.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* Lexer for Scheme. *) - -open Ocs_types -open Ocs_error - -type token = - Leof - | Lopenv (* #( *) - | Lunqsplice (* ,@ *) - | Lident of string - | Lstring of string - | Lnumber of sval - | Lbool of sval - | Lchar of sval - | Ltoken of char - -type lexer - -val make_lexer : Ocs_port.port -> string -> lexer -val get_loc : lexer -> location -val get_tok : lexer -> token - diff --git a/ocs-1.0.3/src/ocs_list.ml b/ocs-1.0.3/src/ocs_list.ml deleted file mode 100644 index 781d948..0000000 --- a/ocs-1.0.3/src/ocs_list.ml +++ /dev/null @@ -1,302 +0,0 @@ -(* List functionality. *) - -open Ocs_types -open Ocs_error -open Ocs_env -open Ocs_misc - -(* Primitives *) - -let make_list av = - let rec loop i r = - if i < 0 then r - else loop (i - 1) (Spair { car = Array.unsafe_get av i; cdr = r }) - in - loop (Array.length av - 1) Snull -;; - -let cons h t = - Spair { car = h; cdr = t } -;; - -let gcar = - function - Spair { car = r; cdr = _ } -> r - | _ -> raise (Error "car: bad args") -;; - -let gcdr = - function - Spair { car = _; cdr = r } -> r - | _ -> raise (Error "cdr: bad args") -;; - -let caar x = gcar (gcar x);; -let cadr x = gcar (gcdr x);; -let cdar x = gcdr (gcar x);; -let cddr x = gcdr (gcdr x);; - -let gcxr seq = - List.fold_left (fun f g -> fun x -> f (g x)) (fun x -> x) seq -;; - -let set_car l v = - match l with - Spair p -> p.car <- v; Sunspec - | _ -> raise (Error "set-car!: bad args") -;; - -let set_cdr l v = - match l with - Spair p -> p.cdr <- v; Sunspec - | _ -> raise (Error "set-cdr!: bad args") -;; - -let safe_length l = - let next = - function - Spair { car = _; cdr = t } -> t - | _ -> raise (Error "length: invalid list") in - let rec loop l r n = - if l == Snull then - n - else if n land 1 = 0 then - loop (next l) r (n + 1) - else if l == r then - raise (Error "length: loop detected") - else - loop (next l) (next r) (n + 1) - in - loop l l 0 -;; - -let is_list l = - try - let _ = safe_length l in Strue - with - _ -> Sfalse -;; - -let length l = - Sint (safe_length l) -;; - -let reverse l = - let rec loop nl = - function - Snull -> nl - | Spair { car = h; cdr = t } -> loop (Spair { car = h; cdr = nl }) t - | _ -> raise (Error "reverse: invalid list") - in - loop Snull l -;; - -(* Copy list and set tail, used by append *) -let cptl tl = - function - Snull -> tl - | Spair { car = h; cdr = t } -> - let nl = Spair { car = h; cdr = Snull } in - let rec loop = - function - Spair p -> - begin - function - Spair { car = h; cdr = t } -> - let n = Spair { car = h; cdr = Snull } in - p.cdr <- n; loop n t - | Snull -> p.cdr <- tl - | _ -> raise (Error "append: bad list") - end - | _ -> assert false - in - loop nl t; nl - | _ -> raise (Error "append: bad list") -;; - -let append = - function - [| |] -> Snull - | av -> - let n = Array.length av in - let rec loop i tl = - if i >= 0 then - loop (i - 1) (cptl tl av.(i)) - else - tl - in - loop (n - 2) av.(n - 1) -;; - -let list_tail l = - function - Sint k -> - begin - let rec tail i x = - if i = 0 then x - else - match x with - Spair { car = _; cdr = t } -> tail (i - 1) t - | _ -> raise (Error "list-tail: bad list") - in - tail k l - end - | _ -> raise (Error "list-tail: bad args") -;; - -let list_ref l k = - match list_tail l k with - Spair { car = x; cdr = _ } -> x - | _ -> raise (Error "list-ref: bad args") -;; - -let rec memq o = - function - Snull -> Sfalse - | Spair { car = x; cdr = t } as p -> if o == x then p else memq o t - | _ -> raise (Error "memq: bad list") -;; - -let rec memv o = - function - Snull -> Sfalse - | Spair { car = x; cdr = t } as p -> - if o == x || test_eqv o x then p else memv o t - | _ -> raise (Error "memv: bad list") -;; - -let rec member o = - function - Snull -> Sfalse - | Spair { car = x; cdr = t } as p -> - if o == x || test_equal o x then p else member o t - | _ -> raise (Error "member: bad list") -;; - -let rec assq o = - function - Snull -> Sfalse - | Spair { car = Spair { car = x; cdr = _ } as p; cdr = t } -> - if o == x then p else assq o t - | _ -> raise (Error "assq: bad list") -;; - -let rec assv o = - function - Snull -> Sfalse - | Spair { car = Spair { car = x; cdr = _ } as p; cdr = t } -> - if o == x || test_eqv o x then p else assv o t - | _ -> raise (Error "assv: bad list") -;; - -let rec assoc o = - function - Snull -> Sfalse - | Spair { car = Spair { car = x; cdr = _ } as p; cdr = t } -> - if o == x || test_equal o x then p else assv o t - | _ -> raise (Error "assoc: bad list") -;; - -let list_to_vector = - function - Snull -> Svector [| |] - | Spair _ as l -> - let n = safe_length l in - let v = Array.make n Snull in - let rec loop i l = - if i < n then - begin - match l with - Spair { car = h; cdr = t } -> v.(i) <- h; loop (i + 1) t - | _ -> assert false (* length was wrong? *) - end - else - () - in - loop 0 l; - Svector v - | _ -> raise (Error "list->vector: bad args") -;; - -let list_to_string = - function - Snull -> Sstring "" - | Spair _ as l -> - let n = safe_length l in - let s = String.create n in - let rec loop i l = - if i < n then - begin - match l with - Spair { car = Schar c; cdr = t } -> s.[i] <- c; loop (i + 1) t - | _ -> raise (Error "list->string: non-characters in list") - end - else - () - in - loop 0 l; - Sstring s - | _ -> raise (Error "list->string: bad args") -;; - -let init e = - set_pf1 e is_list "list?"; - set_pfn e make_list "list"; - set_pf2 e cons "cons"; - - set_pf1 e gcar "car"; - set_pf1 e gcdr "cdr"; - - set_pf1 e caar "caar"; - set_pf1 e cadr "cadr"; - set_pf1 e cdar "cdar"; - set_pf1 e cddr "cddr"; - - set_pf1 e (gcxr [ gcar; gcar; gcar ]) "caaar"; - set_pf1 e (gcxr [ gcar; gcar; gcdr ]) "caadr"; - set_pf1 e (gcxr [ gcar; gcdr; gcar ]) "cadar"; - set_pf1 e (gcxr [ gcar; gcdr; gcdr ]) "caddr"; - set_pf1 e (gcxr [ gcdr; gcar; gcar ]) "cdaar"; - set_pf1 e (gcxr [ gcdr; gcar; gcdr ]) "cdadr"; - set_pf1 e (gcxr [ gcdr; gcdr; gcar ]) "cddar"; - set_pf1 e (gcxr [ gcdr; gcdr; gcdr ]) "cdddr"; - - set_pf1 e (gcxr [ gcar; gcar; gcar; gcar ]) "caaaar"; - set_pf1 e (gcxr [ gcar; gcar; gcar; gcdr ]) "caaadr"; - set_pf1 e (gcxr [ gcar; gcar; gcdr; gcar ]) "caadar"; - set_pf1 e (gcxr [ gcar; gcar; gcdr; gcdr ]) "caaddr"; - set_pf1 e (gcxr [ gcar; gcdr; gcar; gcar ]) "cadaar"; - set_pf1 e (gcxr [ gcar; gcdr; gcar; gcdr ]) "cadadr"; - set_pf1 e (gcxr [ gcar; gcdr; gcdr; gcar ]) "caddar"; - set_pf1 e (gcxr [ gcar; gcdr; gcdr; gcdr ]) "cadddr"; - set_pf1 e (gcxr [ gcdr; gcar; gcar; gcar ]) "cdaaar"; - set_pf1 e (gcxr [ gcdr; gcar; gcar; gcdr ]) "cdaadr"; - set_pf1 e (gcxr [ gcdr; gcar; gcdr; gcar ]) "cdadar"; - set_pf1 e (gcxr [ gcdr; gcar; gcdr; gcdr ]) "cdaddr"; - set_pf1 e (gcxr [ gcdr; gcdr; gcar; gcar ]) "cddaar"; - set_pf1 e (gcxr [ gcdr; gcdr; gcar; gcdr ]) "cddadr"; - set_pf1 e (gcxr [ gcdr; gcdr; gcdr; gcar ]) "cdddar"; - set_pf1 e (gcxr [ gcdr; gcdr; gcdr; gcdr ]) "cddddr"; - - set_pf2 e set_car "set-car!"; - set_pf2 e set_cdr "set-cdr!"; - - set_pf1 e length "length"; - set_pf1 e reverse "reverse"; - - set_pfn e append "append"; - - set_pf2 e list_tail "list-tail"; - set_pf2 e list_ref "list-ref"; - - set_pf2 e memq "memq"; - set_pf2 e memv "memv"; - set_pf2 e member "member"; - set_pf2 e assq "assq"; - set_pf2 e assv "assv"; - set_pf2 e assoc "assoc"; - - set_pf1 e list_to_vector "list->vector"; - set_pf1 e list_to_string "list->string"; -;; - diff --git a/ocs-1.0.3/src/ocs_list.mli b/ocs-1.0.3/src/ocs_list.mli deleted file mode 100644 index 1b9c1da..0000000 --- a/ocs-1.0.3/src/ocs_list.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* List functionality. *) - -open Ocs_types - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_macro.ml b/ocs-1.0.3/src/ocs_macro.ml deleted file mode 100644 index e9afbc6..0000000 --- a/ocs-1.0.3/src/ocs_macro.ml +++ /dev/null @@ -1,438 +0,0 @@ -(* Macro definitions and expanders. *) - -open Ocs_types -open Ocs_error -open Ocs_sym -open Ocs_env -open Ocs_compile -open Ocs_misc - -(* Pattern/template type in syntax rules. *) -type pattern = - Pkeyword of env * sval - | Pvar of sval - | Pvalue of sval - | Ppair of pattern * pattern - | Pvector of pattern array - | Pmulti of pattern * pattern (* pattern ... in a list *) - | Pvmulti of pattern (* pattern ... in a vector *) - | Pmvector of pattern list (* Vector with Pvmulti patterns *) - -type ruleset = { - mutable r_rules : (pattern * pattern) list -} -(* Values of pattern variables *) -type pattvar = - Vitem of sval - | Vmulti of pattvar list - -let rec var_name = - function - Sesym (_, s) -> var_name s - | Ssymbol _ as s -> sym_name s - | _ -> assert false -;; - -let kw_name = - function - Vkeyword s -> s - | _ -> assert false -;; - -(* Parse a pattern or template *) -let parseptt e patt dovar = - let rec parse = - function - Spair { car = h; cdr = t } -> - let x = parse h in - begin - match t with (* Special case, ... *) - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = t } - when is_keyword e s "..." -> Pmulti (x, parse t) - | _ -> Ppair (x, parse t) - end - | (Ssymbol _ | Sesym (_, _)) as s -> dovar s - | Svector v -> - let n = Array.length v - and has_multi = ref false in - let rec loop r i = - if i < 0 then - r - else if safe_is_keyword e v.(i) "..." && i > 0 then - begin - has_multi := true; - loop (Pvmulti (parse v.(i - 1))::r) (i - 2) - end - else - loop (parse v.(i)::r) (i - 1) - in - let nl = loop [] (n - 1) in - if !has_multi then - Pmvector nl - else - Pvector (Array.of_list nl) - | x -> Pvalue x - in - parse patt -;; - -let rec match_sym s s' = - match (s, s') with - Sesym (e, s), Sesym (e', s') -> e == e' && match_sym s s' - | _, _ -> s == s' -;; - -let parsepatt e litlist patt = - let vars = ref [] in - let p = parseptt e patt - (fun s -> - try - let _ = List.find (fun s' -> match_sym s s') litlist in - Pkeyword (e, s) - with Not_found -> - vars := s::!vars; - Pvar s) - in - (!vars, p) -;; - -let parsetmpl e varlist tmpl = - let assocvar = - function - Sesym (e, s) as sym -> - begin - try - Pvar (List.find (function - Sesym (e', s') -> e' == e && s' == s - | _ -> false) varlist) - with Not_found -> - Pvalue sym - end - | s -> if List.memq s varlist then Pvar s else Pvalue s - in - parseptt e tmpl assocvar -;; - -let parserule e ll = - function - Spair { car = Spair { car = _; cdr = patt }; - cdr = Spair { car = tmpl; cdr = Snull }} -> - let (vars, patt) = parsepatt e ll patt in - let tmpl = parsetmpl e vars tmpl in - (patt, tmpl) - | _ -> raise (Error "syntax definition: invalid syntax rule") -;; - -let parsetspec e sym = - function - Spair { car = (Ssymbol _ | Sesym (_, _)) as s; - cdr = Spair { car = literals; cdr = rules }} - when is_keyword e s "syntax-rules" -> - let litlist = list_to_caml literals in - List.map (parserule e litlist) (list_to_caml rules) - | _ -> raise (Error "syntax definition: invalid transformer spec") -;; - -let rebuild a = - let rec loop i r = - if i < 0 then - r - else - loop (i - 1) (Spair { car = a.(i); cdr = r }) - in - loop (Array.length a - 1) Snull -;; - -(* Given a pattern, return an association list of pattern variables - with empty multiple value lists. *) -let rec empty_vars = - function - Pvar v -> [ v, Vmulti [] ] - | Ppair (h, t) -> (empty_vars h) @ (empty_vars t) - | Pmulti (p, t) -> (empty_vars p) @ (empty_vars t) - | Pvmulti p -> empty_vars p - | Pvector v -> - Array.fold_left (@) [] (Array.map empty_vars v) - | Pmvector l -> - List.fold_left (@) [] (List.map empty_vars l) - | _ -> [] -;; - -(* Merge an association list of multi-vars and a set of values *) -let merge_vars mv vs = - let rec merge = - function - (v, Vmulti m)::t -> (v, Vmulti (m @ [ List.assq v vs ]))::(merge t) - | [] -> [] - | _ -> assert false - in - merge mv -;; - -let rec normalize_name = - function - Ssymbol s -> s - | Sesym (_, s) -> normalize_name s - | _ -> "" -;; - -let rec match_patt e patt expr = - let vars = ref [] in - let rec match_sub p x = - match p with - Pkeyword (e', s') -> - begin - match x with - Ssymbol _ | Sesym (_, _) -> (get_var e x) == (get_var e' s') - | _ -> false - end - | Pvar v -> vars := (v, Vitem x)::!vars; true - | Pvalue v -> test_equal v x - | Ppair (h, t) -> - begin - match x with - Spair { car = xh; cdr = xt } -> match_sub h xh && match_sub t xt - | _ -> false - end - | Pvector v -> - begin - match x with - Svector sv -> - let n = Array.length v in - if Array.length sv <> n then - false - else - let rec loop i = - if i = n then - true - else if match_sub v.(i) sv.(i) then - loop (i + 1) - else - false - in - loop 0 - | _ -> false - end - | Pmulti (p, t) -> - if t <> (Pvalue Snull) then - raise (Error "invalid pattern"); - begin - let rec loop r = - function - Spair { car = h; cdr = t } -> - begin - match match_patt e p h with - Some v -> loop (merge_vars r v) t - | None -> None - end - | Snull -> Some r - | _ -> None - in - match loop (empty_vars p) x with - Some vl -> vars := vl @ !vars; true - | None -> false - end - | Pmvector l -> - begin - match x with - Svector v -> - begin - let n = Array.length v in - let rec loop i = - function - Pvmulti p::t -> - if i >= n then - begin - vars := (empty_vars p) @ !vars; - loop i t - end - else - begin - let rec mloop r i = - if i >= n then Some r - else - match match_patt e p v.(i) with - Some v -> mloop (merge_vars r v) (i + 1) - | None -> None - in - match mloop (empty_vars p) i with - Some vl -> vars := vl @ !vars; true - | None -> false - end - | h::t -> - if i >= n then false - else if match_sub h v.(i) then loop (i + 1) t - else false - | [] -> i >= n - in - loop 0 l - end - | _ -> false - end - | _ -> assert false - in - if match_sub patt expr then - Some !vars - else - None -;; - -(* Test whether a variable occurs in a pattern *) -let var_in_patt p (v, _) = - let rec is_in = - function - Pvar pv -> pv == v - | Ppair (h, t) -> is_in h || is_in t - | Pmulti (p, t) -> is_in p || is_in t - | Pvmulti p -> is_in p - | Pvector v -> - let rec loop i = - if i < 0 then false - else if is_in v.(i) then true - else loop (i - 1) - in - loop (Array.length v - 1) - | Pmvector l -> List.exists is_in l - | _ -> false - in - is_in p -;; - -(* Select variables that are applicable to this pattern *) -let subvars vl p = - List.filter (var_in_patt p) vl -;; - -(* Get the current values of variables, if available. *) -let varvals vl = - try - let l = List.map - (function - (v, Vmulti (x::_)) -> (v, x) - | (v, Vmulti []) -> raise Not_found - | x -> x) vl - in - if l = [] then - raise (Error "bad template") - else - (true, l) - with Not_found -> (false, []) -;; - -(* Get the next position in the variable list. *) -let varnext vl = - List.map (function (v, Vmulti (_::t)) -> (v, Vmulti t) | x -> x) vl -;; - -let rec expand_var = - function - Vitem x -> x - | Vmulti m -> make_slist Snull (List.rev_map expand_var m) -;; - -let rec expand_tmpl e tmpl vars = - let rec fix_syms = - function - Ssymbol _ as s -> Sesym (e, s) - | Spair { car = h; cdr = t } -> - Spair { car = fix_syms h; cdr = fix_syms t } - | Svector v -> - Svector (Array.map (fun x -> fix_syms x) v) - | x -> x in - let rec expand_sub = - function - Pvar v -> expand_var (List.assq v vars) - | Pvalue v -> fix_syms v - | Ppair (h, t) -> - Spair { car = expand_sub h; cdr = expand_sub t } - | Pvector v -> - Svector (Array.map (fun x -> expand_sub x) v) - | Pmulti (p, t) -> - let rec loop r v = - let (ok, vv) = varvals v in - if ok then loop ((expand_tmpl e p vv)::r) (varnext v) - else r - in - make_slist (expand_sub t) (loop [] (subvars vars p)) - | Pmvector l -> - begin - let rec loop r = - function - Pvmulti p::t -> - let rec mloop r v = - let (ok, vv) = varvals v in - if ok then mloop ((expand_tmpl e p vv)::r) (varnext v) - else r - in - loop (mloop [] (subvars vars p) @ r) t - | h::t -> loop (expand_sub h::r) t - | [] -> r - in - Svector (Array.of_list (List.rev (loop [] l))) - end - | _ -> assert false - in - expand_sub tmpl -;; - -let expand name me rs e av = - let me = new_scope me in - let al = rebuild av in - let rec try_rule = - function - (patt, tmpl)::t -> - begin - match match_patt e patt al with - Some vars -> expand_tmpl me tmpl vars - | None -> try_rule t - end - | [] -> raise (Error (name ^ ": no matching syntax rule")) - in - try_rule rs.r_rules -;; - -let mkdefine_syntax e = - function - [| (Ssymbol _ | Sesym (_, _)) as sym; tspec |] -> - let rules = parsetspec (new_scope e) sym tspec in - bind_name e sym (Vmacro (expand (normalize_name sym) e - { r_rules = rules })); - Cval Sunspec - | _ -> raise (Error "define-syntax: bad args") -;; - -let mklet_syntax e args = - if Array.length args < 2 then - raise (Error "let-syntax: too few args"); - let av = - Array.map (letsplit (fun s v -> s, - Vmacro (expand (normalize_name s) e { r_rules = parsetspec e s v }))) - (Array.of_list (list_to_caml args.(0))) in - let ne = new_scope e in - Array.iter (fun (s, r) -> bind_name ne s r) av; - mkseq (mkbody ne (Array.sub args 1 (Array.length args - 1))) -;; - -let mkletrec_syntax e args = - if Array.length args < 2 then - raise (Error "letrec-syntax: too few args"); - let ne = new_scope e in - let t = - Array.map (letsplit - (fun s v -> let r = { r_rules = [] } - and name = normalize_name s in - bind_name ne s (Vmacro (expand name ne r)); - r, s, v)) - (Array.of_list (list_to_caml args.(0))) - in - Array.iter (fun (r, s, v) -> r.r_rules <- parsetspec (new_scope e) s v) t; - mkseq (mkbody ne (Array.sub args 1 (Array.length args - 1))) -;; - -let bind_macro e = - bind_name e sym_define_syntax (Vsyntax mkdefine_syntax); - bind_name e sym_let_syntax (Vsyntax mklet_syntax); - bind_name e sym_letrec_syntax (Vsyntax mkletrec_syntax); - bind_name e sym_ellipsis (Vkeyword "...") -;; - diff --git a/ocs-1.0.3/src/ocs_macro.mli b/ocs-1.0.3/src/ocs_macro.mli deleted file mode 100644 index 80b6b20..0000000 --- a/ocs-1.0.3/src/ocs_macro.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* Syntax definitions and expansions. *) - -open Ocs_types - -val bind_macro : env -> unit - diff --git a/ocs-1.0.3/src/ocs_main.ml b/ocs-1.0.3/src/ocs_main.ml deleted file mode 100644 index 36a4bb7..0000000 --- a/ocs-1.0.3/src/ocs_main.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* Main program entry point. *) - -open Ocs_types -open Ocs_error - -let main () = - let loadf = ref [] in - let addf x = loadf := !loadf @ [x] in - let argspec = [ - ("file", Arg.Rest addf, "Files to run in batch mode") - ] in - Arg.parse argspec addf "Usage: ocscm [ file ... ]"; - if !loadf = [] then - Ocs_top.interactive () - else - let e = Ocs_top.make_env () - and th = Ocs_top.make_thread () in - try - List.iter (fun x -> Ocs_prim.load_file e th x) !loadf - with - Error err -> - Printf.eprintf "Error: %s\n" err - | ErrorL ((file, line), err) -> - Printf.eprintf "%s:%d: %s\n" file line err -;; - -main ();; - diff --git a/ocs-1.0.3/src/ocs_misc.ml b/ocs-1.0.3/src/ocs_misc.ml deleted file mode 100644 index d72ebf6..0000000 --- a/ocs-1.0.3/src/ocs_misc.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* Miscellaneous utility functions *) - -open Ocs_types -open Ocs_error - -let list_to_caml l = - let rec loop r = - function - Snull -> List.rev r - | Spair p -> loop (p.car::r) p.cdr - | _ -> raise (Error "not a valid list") - in - loop [] l -;; - -(* Create a Scheme list from a reversed native list. *) -let make_slist tl l = - let rec loop r = - function - h::t -> loop (Spair { car = h; cdr = r }) t - | [] -> r - in - loop tl l -;; - -(* Create one of Capply[0123n] depending on the number of arguments. *) -let mkapply f av = - match av with - [| |] -> Capply0 (f) - | [| a1 |] -> Capply1 (f, a1) - | [| a1; a2 |] -> Capply2 (f, a1, a2) - | [| a1; a2; a3 |] -> Capply3 (f, a1, a2, a3) - | av -> Capplyn (f, av) -;; - -(* Test equivalence (as in eqv?) *) - -let test_eqv a b = - if a == b then true - else - match (a, b) with - (Sint i1, Sint i2) -> i1 = i2 - | (Schar c1, Schar c2) -> c1 = c2 - | (Sreal r1, Sreal r2) -> r1 = r2 - | (Sbigint bi1, Sbigint bi2) -> Big_int.compare_big_int bi1 bi2 = 0 - | (Srational r1, Srational r2) -> Ratio.compare_ratio r1 r2 = 0 - | (Scomplex z1, Scomplex z2) -> z1 = z2 - | (Sstring s1, Sstring s2) -> s1 = s2 - | (Svector v1, Svector v2) -> v1 == v2 - | _ -> false -;; - -(* Test equality (as in equal?) *) - -let rec test_equal a b = - if a == b then true - else - match (a, b) with - (Svector v1, Svector v2) -> - let n = Array.length v1 in - if Array.length v2 <> n then - false - else - let rec loop i = - if i >= n then - true - else - if test_equal v1.(i) v2.(i) then - loop (i + 1) - else - false - in - loop 0 - | (Spair p1, Spair p2) -> - test_equal p1.car p2.car && test_equal p1.cdr p2.cdr - | _ -> test_eqv a b -;; diff --git a/ocs-1.0.3/src/ocs_misc.mli b/ocs-1.0.3/src/ocs_misc.mli deleted file mode 100644 index 229ec35..0000000 --- a/ocs-1.0.3/src/ocs_misc.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* Miscellaneous utility functions *) - -open Ocs_types - -val list_to_caml : sval -> sval list - -val make_slist : sval -> sval list -> sval - -val mkapply : code -> code array -> code - -val test_eqv : sval -> sval -> bool -val test_equal : sval -> sval -> bool diff --git a/ocs-1.0.3/src/ocs_num.ml b/ocs-1.0.3/src/ocs_num.ml deleted file mode 100644 index 5de1fc9..0000000 --- a/ocs-1.0.3/src/ocs_num.ml +++ /dev/null @@ -1,633 +0,0 @@ -(* Handle number types (Sint, Sreal, Sbigint, Srational, Scomplex) *) - -open Ocs_types -open Ocs_error -open Ocs_env -open Ocs_numaux -open Ocs_complex - -open Num -open Ratio -open Big_int - -let rec negate = - function - (Sint i) as s -> - if i >= min_int then Sint (-i) - else negate (promote_bigint s) - | Sbigint bi -> Sbigint (minus_big_int bi) - | Srational r -> Srational (Ratio.minus_ratio r) - | Sreal r -> Sreal (-.r) - | Scomplex z -> Scomplex (Complex.neg z) - | _ -> raise (Error "bad number type") -;; - -let add2 a b = - match (a, b) with - (Sint i1, Sint i2) -> - let r = i1 + i2 in - if (i1 lxor i2) lor (i1 lxor (r lxor (-1))) < 0 - then Sint r - else Sbigint (add_big_int (big_int_of_int i1) (big_int_of_int i2)) - | (Scomplex z1, Scomplex z2) -> Scomplex (Complex.add z1 z2) - | (Scomplex z, o) | (o, Scomplex z) -> - Scomplex (Complex.add z { Complex.re = float_of_snum o; - Complex.im = 0.0 }) - | (Sreal r, o) | (o, Sreal r) -> - Sreal ((float_of_snum o) +. r) - | (Srational r, o) | (o, Srational r) -> - Srational (add_ratio (rational_of_snum o) r) - | (Sbigint bi, o) | (o, Sbigint bi) -> - bigint_res (add_big_int (bigint_of_snum o) bi) - | _ -> raise (Error "add: bad types") -;; - -let sub2 a b = - add2 a (negate b) -;; - -let mul2 a b = - match snum_fixtypes a b with - (Scomplex z1, Scomplex z2) -> Scomplex (Complex.mul z1 z2) - | (Sreal r1, Sreal r2) -> Sreal (r1 *. r2) - | (Srational r1, Srational r2) -> - snum_of_num (mult_num (Ratio r1) (Ratio r2)) - | (Sbigint bi1, Sbigint bi2) -> - snum_of_num (mult_num (Big_int bi1) (Big_int bi2)) - | (Sint i1, Sint i2) -> - snum_of_num (mult_num (Int i1) (Int i2)) - | _ -> raise (Error "mul: invalid args") -;; - -let div2 a b = - match snum_fixtypes a b with - (Scomplex n, Scomplex d) -> Scomplex (Complex.div n d) - | (Sreal n, Sreal d) -> Sreal (n /. d) - | (Srational n, Srational d) -> - snum_of_num (div_num (Ratio n) (Ratio d)) - | (Sbigint n, Sbigint d) -> - snum_of_num (div_num (Big_int n) (Big_int d)) - | (Sint n, Sint d) -> - if d = 0 then - raise (Error "division by zero") - else - snum_of_num (div_num (Int n) (Int d)) - | _ -> raise (Error "div: invalid args") -;; - -let cmp2 eq_only a b = - match (a, b) with - (Sint i1, Sint i2) -> - if i1 > i2 then 1 else if i1 < i2 then -1 else 0 - | _ -> - begin - match snum_fixtypes a b with - (Sreal r1, Sreal r2) -> - let r = r1 -. r2 in - if r > 0.0 then 1 else if r < 0.0 then -1 else 0 - | (Scomplex z1, Scomplex z2) -> - if eq_only then - if z1 = z2 then 0 else 1 - else - if z1.Complex.im = 0.0 && z2.Complex.im = 0.0 then - begin - let r = z1.Complex.re -. z2.Complex.re in - if r > 0.0 then 1 else if r < 0.0 then -1 else 0 - end - else - raise (Error "complex numbers compared") - | (Srational r1, Srational r2) -> - compare_ratio r1 r2 - | (Sbigint bi1, Sbigint bi2) -> - compare_big_int bi1 bi2 - | _ -> raise (Error "cmp: invalid args") - end -;; - -let is_exact = - function - (Sint _ | Sbigint _ | Srational _) -> Strue - | _ -> Sfalse -;; - -let is_inexact = - function - (Sreal _ | Scomplex _) -> Strue - | _ -> Sfalse -;; - -let to_exact = - function - Sreal r -> float_to_exact r - | Scomplex z -> - if z.Complex.im = 0.0 then - float_to_exact z.Complex.re - else - raise (Error "inexact->exact: no exact complex representation") - | (Sint _ | Sbigint _ | Srational _) as n -> n - | _ -> raise (Error "inexact->exact: not a number") -;; - -let to_inexact = - function - Sreal _ as r -> r - | Scomplex _ as z -> z - | x -> Sreal (float_of_snum x) -;; - -let mkbool b = if b then Strue else Sfalse;; - -let is_zero = - function - Sint i -> mkbool (i = 0) - | (Sbigint _ | Srational _) -> Sfalse - | Sreal r -> mkbool (r = 0.0) - | Scomplex z -> mkbool (z.Complex.re = 0.0 && z.Complex.im = 0.0) - | _ -> Sfalse -;; - -let is_positive = - function - Sint i -> mkbool (i > 0) - | Sbigint bi -> mkbool (sign_big_int bi > 0) - | Srational r -> mkbool (sign_ratio r > 0) - | Sreal r -> mkbool (r > 0.0) - | _ -> raise (Error "positive?: bad arg type") -;; - -let is_negative = - function - Sint i -> mkbool (i < 0) - | Sbigint bi -> mkbool (sign_big_int bi < 0) - | Srational r -> mkbool (sign_ratio r < 0) - | Sreal r -> mkbool (r < 0.0) - | _ -> raise (Error "positive?: bad arg type") -;; - -let is_number = - function - Sint _ | Sbigint _ | Srational _ | Sreal _ | Scomplex _ -> Strue - | _ -> Sfalse -;; - -let is_real = - function - Sint _ | Sbigint _ | Srational _ | Sreal _ -> Strue - | Scomplex { Complex.re = _; Complex.im = i } -> mkbool (i = 0.0) - | _ -> Sfalse -;; - -let is_rational = - is_real -;; - -let is_integer = - function - Sint _ | Sbigint _ -> Strue - | Sreal r -> mkbool (float_is_int r) - | Scomplex z -> mkbool (z.Complex.im = 0.0 && float_is_int z.Complex.re) - | _ -> Sfalse -;; - -let bi_modi bi i = - int_of_big_int (mod_big_int bi (big_int_of_int i)) -;; - -let is_even = - function - Sint i -> mkbool (i land 1 = 0) - | Sbigint bi -> mkbool (bi_modi bi 2 = 0) - | _ -> raise (Error "even?: bad arg type") -;; - -let is_odd = - function - Sint i -> mkbool (i land 1 <> 0) - | Sbigint bi -> mkbool (bi_modi bi 2 <> 0) - | _ -> raise (Error "odd?: bad arg type") -;; - -let do_ops op av n = - let rec oploop v i = - if i < n then - let r = op v av.(i) in - oploop r (i + 1) - else - v - in - oploop av.(0) 1 -;; - -let snum_add av = - let n = Array.length av in - if n = 0 then - Sint 0 - else - do_ops add2 av n -;; - -let snum_sub av = - match Array.length av with - 0 -> raise (Error "-: need args") - | 1 -> negate av.(0) - | n -> do_ops sub2 av n -;; - -let snum_mul av = - match Array.length av with - 0 -> Sint 1 - | n -> do_ops mul2 av n -;; - -let snum_div av = - match Array.length av with - 0 -> raise (Error "/: need args") - | 1 -> div2 (Sint 1) av.(0) - | n -> do_ops div2 av n -;; - -let snum_eq av = - match Array.length av with - 0 | 1 -> Strue - | n -> - let a0 = av.(0) in - let rec loop i = - if i < n then - begin - if cmp2 true a0 av.(i) <> 0 then Sfalse - else loop (i + 1) - end - else - Strue - in - loop 1 -;; - -let snum_rel op av = - match Array.length av with - 0 | 1 -> Strue - | n -> - let rec loop v i = - if i < n then - begin - if op (cmp2 false v av.(i)) 0 then loop av.(i) (i + 1) - else Sfalse - end - else - Strue - in - loop av.(0) 1 -;; - -let snum_minormax op av = - match Array.length av with - 0 -> raise (Error "args required") - | 1 -> av.(0) - | n -> - let inex = ref false in - let r = do_ops (fun a b -> - if is_inexact a = Strue || is_inexact b = Strue then - inex := true; - if op (cmp2 false a b) 0 then a else b) av n - in - if !inex then to_inexact r else r -;; - -let snum_abs = - function - Sint i -> Sint (abs i) - | Sbigint bi -> Sbigint (abs_big_int bi) - | Sreal r -> Sreal (abs_float r) - | Srational r -> Srational (abs_ratio r) - | Scomplex _ -> raise (Error "abs: number is complex") - | _ -> raise (Error "abs: not a number") -;; - -let snum_floor = - function - (Sint _ | Sbigint _) as x -> x - | Srational r -> bigint_res (floor_ratio r) - | Sreal r -> Sreal (floor r) - | _ -> raise (Error "floor: bad arg type") -;; - -let snum_ceiling = - function - (Sint _ | Sbigint _) as x -> x - | Srational r -> bigint_res (ceiling_ratio r) - | Sreal r -> Sreal (ceil r) - | _ -> raise (Error "ceiling: bad arg type") -;; - -let snum_truncate = - function - (Sint _ | Sbigint _) as x -> x - | Srational r -> bigint_res (integer_ratio r) - | Sreal r -> - if r < 0.0 then - Sreal (ceil r) - else - Sreal (floor r) - | _ -> raise (Error "truncate: bad arg type") -;; - -let snum_round = - function - (Sint _ | Sbigint _) as x -> x - | Srational r -> bigint_res (round_ratio r) - | Sreal r -> Sreal (round_float r) - | _ -> raise (Error "round: bad arg type") -;; - -let rcsw rfun cfun = - function - Scomplex z -> Scomplex (cfun z) - | x -> Sreal (rfun (float_of_snum x)) -;; - -let snum_exp = rcsw exp Complex.exp;; -let snum_log = rcsw log Complex.log;; - -let snum_sin = rcsw sin sin_cplx;; -let snum_cos = rcsw cos cos_cplx;; -let snum_tan = rcsw tan tan_cplx;; -let snum_asin = rcsw asin asin_cplx;; -let snum_acos = rcsw acos acos_cplx;; - -let snum_atan = - function - [| x |] -> rcsw atan atan_cplx x - | [| y; x |] -> - Sreal (Complex.arg { Complex.re = float_of_snum x; - Complex.im = float_of_snum y }) - | _ -> raise (Error "atan: bad args") -;; - -let snum_sqrt = - function - Scomplex z -> Scomplex (Complex.sqrt z) - | x -> - let r = float_of_snum x in - if r < 0.0 then - Scomplex (Complex.sqrt { Complex.re = r; Complex.im = 0.0 }) - else - let sq = sqrt r in - if is_exact x <> Sfalse && float_is_int sq then - float_to_exact sq - else - Sreal sq -;; - -(* Optimize the simplest cases, leave the rest to Num. *) -let snum_expt x y = - match (x, y) with - (_, Sint n) when n = 0 -> Sint 1 - | ((Sint _ | Sbigint _), Sint n) when n > 0 -> - bigint_res (power_big_int_positive_int (bigint_of_snum x) n) - | ((Sint _ | Sbigint _ | Srational _), (Sint _ | Sbigint _)) -> - snum_of_num (power_num (num_of_snum x) (num_of_snum y)) - | (Scomplex _, _) | (_, Scomplex _) -> - Scomplex (Complex.pow (complex_of_snum x) (complex_of_snum y)) - | _ -> - Sreal (float_of_snum x ** float_of_snum y) -;; - -let make_rectangular x y = - Scomplex { Complex.re = float_of_snum x; Complex.im = float_of_snum y } -;; - -let make_polar x y = - Scomplex (Complex.polar (float_of_snum x) (float_of_snum y)) -;; - -let real_part x = - Sreal (complex_of_snum x).Complex.re -;; - -let imag_part x = - Sreal (complex_of_snum x).Complex.im -;; - -let magnitude x = - Sreal (Complex.norm (complex_of_snum x)) -;; - -let angle x = - Sreal (Complex.arg (complex_of_snum x)) -;; - -let quotient n d = - match (n, d) with - ((Sint _ | Sbigint _ | Srational _), - (Sint _ | Sbigint _ | Srational _)) -> - snum_of_num (integer_num (div_num (num_of_snum n) (num_of_snum d))) - | _ -> - let n = float_of_snum n - and d = float_of_snum d in - if not (float_is_int n && float_is_int d) then - raise (Error "quotient: non-integer arguments") - else - Sreal (n /. d -. (mod_float n d) /. d) -;; - -let remainder n d = - match (n, d) with - ((Sint _ | Sbigint _ | Srational _), - (Sint _ | Sbigint _ | Srational _)) -> - let n = num_of_snum n - and d = num_of_snum d in - let m = mod_num n d in - if sign_num n + sign_num d = 0 then - snum_of_num (sub_num m d) - else - snum_of_num m - | _ -> - let n = float_of_snum n - and d = float_of_snum d in - if not (float_is_int n && float_is_int d) then - raise (Error "quotient: non-integer arguments") - else - Sreal (mod_float n d) -;; - -let modulo n d = - match (n, d) with - ((Sint _ | Sbigint _ | Srational _), - (Sint _ | Sbigint _ | Srational _)) -> - snum_of_num (mod_num (num_of_snum n) (num_of_snum d)) - | _ -> - let n = float_of_snum n - and d = float_of_snum d in - if not (float_is_int n && float_is_int d) then - raise (Error "quotient: non-integer arguments") - else - let m = mod_float n d in - if (n < 0.0 && d > 0.0) || (n > 0.0 && d < 0.0) then - Sreal (d +. m) - else - Sreal m -;; - -(* Compute the gcd of two numbers *) -let rec gcd2 a b = - match (a, b) with - ((Sint _ | Sbigint _), (Sint _ | Sbigint _)) -> - bigint_res (gcd_big_int (bigint_of_snum (snum_abs a)) - (bigint_of_snum (snum_abs b))) - | _ -> - if is_integer a <> Sfalse && is_integer b <> Sfalse then - to_inexact (gcd2 (to_exact a) (to_exact b)) - else - raise (Error "gcd: non-integer arguments") -;; - -let snum_gcd av = - let n = Array.length av in - if n = 0 then - Sint 0 - else - do_ops gcd2 av n -;; - -let lcm2 a b = - let g = gcd2 a b in - snum_abs (mul2 (div2 a g) b) -;; - -let snum_lcm av = - let n = Array.length av in - if n = 0 then - Sint 1 - else - do_ops lcm2 av n -;; - -(* The algorithm for calculating the simplest rational form of a number - is translated from the appendix in the IEEE draft. It implicitly - preserves exactness. *) - -let simplest_rational x y = - let one = Sint 1 in - let rec sri x y = - let fx = snum_floor x - and fy = snum_floor y in - if cmp2 false fx x >= 0 then - fx - else if cmp2 true fx fy = 0 then - add2 fx - (div2 one (sri (div2 one (sub2 y fy)) (div2 one (sub2 x fx)))) - else - add2 fx one - in - if cmp2 false y x < 0 then - sri y x - else if cmp2 false x y >= 0 then - begin - if is_rational x <> Sfalse then - x - else - raise (Error "rationalize: not a rational") - end - else if is_positive x <> Sfalse then - sri x y - else if is_negative y <> Sfalse then - negate (sri (negate y) (negate x)) - else if is_exact x <> Sfalse && is_exact y <> Sfalse then - Sint 0 - else - Sreal 0.0 -;; - -let snum_rationalize x e = - simplest_rational (sub2 x e) (add2 x e) -;; - -let rec snum_numerator = - function - (Sint _ | Sbigint _) as x -> x - | Srational q -> bigint_res (numerator_ratio q) - | Sreal _ as x -> to_inexact (snum_numerator (to_exact x)) - | Scomplex _ -> raise (Error "numerator: not defined for complex numbers") - | _ -> raise (Error "numerator: not a numeric type") -;; - -let rec snum_denominator = - function - Sint _ | Sbigint _ -> Sint 1 - | Srational q -> bigint_res (denominator_ratio q) - | Sreal r as x -> - if r = 0.0 then Sreal 1.0 else - to_inexact (snum_denominator (to_exact x)) - | Scomplex _ -> raise (Error "denominator: not defined for complex numbers") - | _ -> raise (Error "denominator: not a numeric type") -;; - -let init e = - set_pf1 e is_exact "exact?"; - set_pf1 e is_inexact "inexact?"; - set_pf1 e is_zero "zero?"; - set_pf1 e is_positive "positive?"; - set_pf1 e is_negative "negative?"; - set_pf1 e is_number "number?"; - set_pf1 e is_number "complex?"; - set_pf1 e is_real "real?"; - set_pf1 e is_rational "rational?"; - set_pf1 e is_integer "integer?"; - set_pf1 e is_even "even?"; - set_pf1 e is_odd "odd?"; - - set_pfn e snum_add "+"; - set_pfn e snum_sub "-"; - set_pfn e snum_mul "*"; - set_pfn e snum_div "/"; - set_pfn e snum_eq "="; - set_pfn e (snum_rel (>)) ">"; - set_pfn e (snum_rel (<)) "<"; - set_pfn e (snum_rel (>=)) ">="; - set_pfn e (snum_rel (<=)) "<="; - - set_pfn e (snum_minormax (>)) "max"; - set_pfn e (snum_minormax (<)) "min"; - - set_pf1 e snum_abs "abs"; - - set_pf1 e snum_floor "floor"; - set_pf1 e snum_ceiling "ceiling"; - set_pf1 e snum_truncate "truncate"; - set_pf1 e snum_round "round"; - - set_pf1 e snum_exp "exp"; - set_pf1 e snum_log "log"; - - set_pf1 e snum_sin "sin"; - set_pf1 e snum_cos "cos"; - set_pf1 e snum_tan "tan"; - set_pf1 e snum_asin "asin"; - set_pf1 e snum_acos "acos"; - set_pfn e snum_atan "atan"; - - set_pf1 e snum_sqrt "sqrt"; - set_pf2 e snum_expt "expt"; - - set_pf2 e make_rectangular "make-rectangular"; - set_pf2 e make_polar "make-polar"; - set_pf1 e real_part "real-part"; - set_pf1 e imag_part "imag-part"; - set_pf1 e magnitude "magnitude"; - set_pf1 e angle "angle"; - - set_pf2 e quotient "quotient"; - set_pf2 e remainder "remainder"; - set_pf2 e modulo "modulo"; - - set_pf1 e to_exact "inexact->exact"; - set_pf1 e to_inexact "exact->inexact"; - - set_pfn e snum_gcd "gcd"; - set_pfn e snum_lcm "lcm"; - - set_pf2 e snum_rationalize "rationalize"; - - set_pf1 e snum_numerator "numerator"; - set_pf1 e snum_denominator "denominator"; -;; diff --git a/ocs-1.0.3/src/ocs_num.mli b/ocs-1.0.3/src/ocs_num.mli deleted file mode 100644 index 6840dd6..0000000 --- a/ocs-1.0.3/src/ocs_num.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* Operations on number types. *) - -open Ocs_types - -val negate : sval -> sval - -val add2 : sval -> sval -> sval -val sub2 : sval -> sval -> sval -val mul2 : sval -> sval -> sval -val div2 : sval -> sval -> sval - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_numaux.ml b/ocs-1.0.3/src/ocs_numaux.ml deleted file mode 100644 index eb7fa7a..0000000 --- a/ocs-1.0.3/src/ocs_numaux.ml +++ /dev/null @@ -1,201 +0,0 @@ -(* Numeric utility functions. *) - -open Ocs_types -open Ocs_error - -open Num -open Ratio -open Big_int - -let fix_floating_precision () = - let n = Arith_status.get_floating_precision () in - if n < 25 then - Arith_status.set_floating_precision 25 -;; - -fix_floating_precision ();; - -Arith_status.set_normalize_ratio true;; - -let promote_real = - function - Sint i -> Sreal (float_of_int i) - | (Sreal _) as r -> r - | (Scomplex _) as z -> z - | Sbigint bi -> Sreal (float_of_big_int bi) - | Srational r -> Sreal (float_of_ratio r) - | _ -> raise (Error "bad number type") -;; - -let float_of_snum = - function - Sint i -> float_of_int i - | Sreal r -> r - (* Note - the imaginary part is discarded! *) - | Scomplex { Complex.re = r; Complex.im = _ } -> r - | Sbigint bi -> float_of_big_int bi - | Srational r -> float_of_ratio r - | _ -> raise (Error "bad number type") -;; - -let promote_complex = - function - (Scomplex _) as z -> z - | x -> Scomplex { Complex.re = float_of_snum x; Complex.im = 0.0 } -;; - -let complex_of_snum = - function - Scomplex z -> z - | x -> { Complex.re = float_of_snum x; Complex.im = 0.0 } -;; - -let rational_of_snum = - function - Sbigint bi -> ratio_of_big_int bi - | Sint i -> ratio_of_int i - | Srational r -> r - | _ -> raise (Error "bad number type") -;; - -let promote_rational s = - Srational (rational_of_snum s) -;; - -let bigint_of_snum = - function - Sint i -> big_int_of_int i - | Sbigint bi -> bi - | _ -> raise (Error "bad number type") -;; - -let promote_bigint = - function - Sint i -> Sbigint (big_int_of_int i) - | (Sbigint _) as bi -> bi - | _ -> raise (Error "bad number type") -;; - -let snum_fixtypes a b = - match (a, b) with - (Sint _, Sint _) -> a, b - | (Scomplex _, _) -> a, promote_complex b - | (_, Scomplex _) -> (promote_complex a), b - | (Sreal _, _) -> a, promote_real b - | (_, Sreal _) -> (promote_real a), b - | (Srational _, _) -> a, promote_rational b - | (_, Srational _) -> (promote_rational a), b - | (Sbigint _, _) -> a, promote_bigint b - | (_, Sbigint _) -> (promote_bigint a), b - | _ -> raise (Error "snum_fixtypes: not numeric types") -;; - -let snum_of_num = - function - Int x -> Sint x - | Big_int x -> Sbigint x - | Ratio x -> Srational x -;; - -let num_of_snum = - function - Sint x -> Int x - | Sbigint x -> Big_int x - | Srational x -> Ratio x - | _ -> raise (Error "bad number type") -;; - -(* Return a result as the simplest representation of a given bigint *) -let bigint_res bi = - if is_int_big_int bi then - Sint (int_of_big_int bi) - else - Sbigint bi -;; - -let round_float r = - let d = floor (r +. 0.5) - and e = ceil (r -. 0.5) in - if d <> e && (mod_float e 2.0) = 0.0 then e - else d -;; - -let float_is_int f = - let (x, _) = modf f in - x = 0.0 -;; - -let max_f_int = 2.0 ** (float_of_int (Sys.word_size - 2)) -. 1.0;; -let min_f_int = -.max_f_int -. 1.0;; - -(* We need to deconstruct IEEE floats to convert them. *) -let fe_bits = Int64.of_string "0x7ff0000000000000";; -let fm_bits = Int64.of_string "0x000fffffffffffff";; -let fi_bit = Int64.of_string "0x0010000000000000";; -let fs_bit = Int64.of_string "0x8000000000000000";; - -let fb_get_dm fb = - Int64.logand fb fm_bits -;; - -let fb_get_m fb = - Int64.logor (fb_get_dm fb) fi_bit -;; - -let fb_get_e fb = - Int64.to_int (Int64.shift_right (Int64.logand fb fe_bits) 52) - 1023 -;; - -let fb_get_s fb = - Int64.compare (Int64.logand fb fs_bit) Int64.zero <> 0; -;; - -let f_is_int m e = - if e < 0 then false - else if e >= 52 then true - else Int64.compare (Int64.logand fm_bits - (Int64.shift_left m e)) Int64.zero = 0 -;; - -(* Convert an int64 into a bigint, possibly ignoring the most - significant 4 bits (on 32-bit machines). This is good enough - for the 52 + 1 -bit mantissa of 64-bit IEEE floats. *) -let big_int_of_int64 i = - if Sys.word_size = 64 then - (big_int_of_int (Int64.to_int i)) - else (* Assume 32 *) - let lo = Int64.to_int i land 0x3fffffff - and hi = Int64.to_int (Int64.shift_right i 30) in - add_big_int (big_int_of_int lo) - (mult_big_int (big_int_of_int hi) (power_int_positive_int 2 30)) -;; - -let float_to_exact f = - if float_is_int f && f >= min_f_int && f <= max_f_int then - Sint (int_of_float f) - else if f = infinity || f = neg_infinity || f = nan then - raise (Error "invalid float") - else - let fb = Int64.bits_of_float f in - let m = fb_get_m fb - and e = fb_get_e fb - and is_neg = fb_get_s fb in - let bm = big_int_of_int64 m in - if f_is_int m e then - let wrap = if is_neg then minus_big_int else fun x -> x in - if e = 52 then - Sbigint (wrap bm) - else if e > 52 then - Sbigint (wrap (mult_big_int bm (power_int_positive_int 2 (e - 52)))) - else - Sbigint (wrap (div_big_int bm (power_int_positive_int 2 (52 - e)))) - else - let wrap = if is_neg then minus_ratio else fun x -> x in - if e < -1022 then (* not normalized, no implied mantissa bit *) - Srational (wrap (create_ratio (big_int_of_int64 (fb_get_dm fb)) - (power_int_positive_int 2 (51 - e)))) - else - Srational (wrap (create_ratio bm - (power_int_positive_int 2 (52 - e)))) -;; - diff --git a/ocs-1.0.3/src/ocs_numaux.mli b/ocs-1.0.3/src/ocs_numaux.mli deleted file mode 100644 index 3527676..0000000 --- a/ocs-1.0.3/src/ocs_numaux.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Numeric utility functions. *) - -open Ocs_types - -open Num -open Ratio -open Big_int - -val promote_real : sval -> sval -val promote_complex : sval -> sval -val promote_rational : sval -> sval -val promote_bigint : sval -> sval - -val complex_of_snum : sval -> Complex.t -val float_of_snum : sval -> float -val rational_of_snum : sval -> ratio -val bigint_of_snum : sval -> big_int - -val snum_fixtypes : sval -> sval -> sval * sval - -val snum_of_num : num -> sval -val num_of_snum : sval -> num - -val bigint_res : big_int -> sval - -val round_float : float -> float -val float_is_int : float -> bool -val float_to_exact : float -> sval - diff --git a/ocs-1.0.3/src/ocs_numstr.ml b/ocs-1.0.3/src/ocs_numstr.ml deleted file mode 100644 index fdf4825..0000000 --- a/ocs-1.0.3/src/ocs_numstr.ml +++ /dev/null @@ -1,403 +0,0 @@ -(* Conversions between numbers and strings. *) - -open Ocs_types -open Ocs_error -open Ocs_numaux -open Ocs_num -open Ocs_env - -open Num -open Big_int -open Ratio - -(* We need to scan strings and keep track of our position. *) - -type sbuf = { - s_str : string; - mutable s_pos : int -} - -let speek s = - if s.s_pos < String.length s.s_str then - Some s.s_str.[s.s_pos] - else - None -;; - -let skip s = - s.s_pos <- s.s_pos + 1 -;; - -let sget s = - match speek s with - (Some _) as c -> skip s; c - | _ -> None -;; - -let ssleft s = - (String.length s.s_str) - s.s_pos -;; - -(* Converting strings to numbers is fairly complex. We have a lot of - cases to consider. *) - -type exactness = - Exact - | Inexact - | Undef - -let parse_prefix s = - let rec nextp b e = - match speek s with - Some '#' -> - begin - skip s; - match sget s with - Some ('E' | 'e') -> - if e <> Undef then raise (Error "invalid #e") else nextp b Exact - | Some ('I' | 'i') -> - if e <> Undef then raise (Error "invalid #i") else nextp b Inexact - | Some ('B' | 'b') -> - if b <> 0 then raise (Error "invalid #b") else nextp 2 e - | Some ('O' | 'o') -> - if b <> 0 then raise (Error "invalid #o") else nextp 8 e - | Some ('D' | 'd') -> - if b <> 0 then raise (Error "invalid #d") else nextp 10 e - | Some ('X' | 'x') -> - if b <> 0 then raise (Error "invalid #x") else nextp 16 e - | _ -> raise (Error "invalid prefix") - end - | _ -> (b, e) - in - nextp 0 Undef -;; - -let strtobi s base = - let n = String.length s - and am v i = add_int_big_int i (mult_int_big_int base v) in - let rec loop i v = - if i >= n then - v - else - loop (i + 1) (am v - (match s.[i] with - '0' .. '9' as c -> int_of_char c - int_of_char '0' - | 'a' .. 'f' as c -> int_of_char c - int_of_char 'a' + 10 - | 'A' .. 'F' as c -> int_of_char c - int_of_char 'A' + 10 - | _ -> raise (Error "invalid number"))) - in - loop 0 (big_int_of_int 0) -;; - -let read_bigint s base = - if base = 10 then - big_int_of_string s - else - strtobi s base -;; - -(* The largest integer is at *least* this big (bigger on 64-bit machines). *) -let max_int = 0x3fffffff -let min_int = -max_int - 1 - -let parse_num s base = - let fixsign = - match speek s with - Some '-' -> skip s; negate - | Some '+' -> skip s; fun x -> x - | _ -> fun x -> x - and maxv = max_int / base - and maxi = max_int mod base - in - let rec scann v o = - match speek s with - Some ('0' .. '9' as c) - when (int_of_char c) - (int_of_char '0') < base -> - addo v ((int_of_char c) - (int_of_char '0')) o - | Some ('a' .. 'f' as c) when base = 16 -> - addo v ((int_of_char c) - (int_of_char 'a') + 10) o - | Some ('A' .. 'F' as c) when base = 16 -> - addo v ((int_of_char c) - (int_of_char 'A') + 10) o - | _ -> (v, o) - and addo v i o = - skip s; - if o || v > maxv || (v = maxv && i > maxi) then - scann 0 true - else - scann (v * base + i) o - and readn () = - let sp = s.s_pos in - match scann 0 false with - (i, false) -> - if s.s_pos = sp then - raise (Error "invalid number") - else - Sint i - | (_, true) -> - Sbigint (read_bigint (String.sub s.s_str sp (s.s_pos - sp)) base) - in - let num = readn () in - match speek s with - Some '/' -> - skip s; - fixsign (div2 (Sbigint (bigint_of_snum num)) - (Sbigint (bigint_of_snum (readn ())))) - | Some ('+' | '-' | '@') | None -> fixsign num - | _ -> raise (Error "invalid rational") -;; - -let parse_flo10 s = - let sp = s.s_pos in - let rec skipd isfirst = - match speek s with - Some '0' .. '9' | Some '#' -> skip s; skipd false - | Some ('+' | '-') when isfirst -> skip s; skipd false - | _ -> () - in - skipd true; - if speek s = Some '.' then - begin - skip s; - skipd false - end; - begin - match speek s with - Some ('E' | 'e' | 'F' | 'f' | 'D' | 'd' | 'S' | 's' | 'L' | 'l') -> - skip s; skipd true - | _ -> () - end; - let t = String.sub s.s_str sp (s.s_pos - sp) in - for i = 0 to String.length t - 1 do - match t.[i] with - '#' -> t.[i] <- '0' - | 'F' | 'f' | 'D' | 'd' | 'S' | 's' | 'L' | 'l' -> t.[i] <- 'e' - | _ -> () - done; - try - Sreal (float_of_string t) - with - Failure _ -> raise (Error "invalid float") -;; - -let string_to_num str ub = - (* Special cases for [-+][iI] *) - if str = "+i" || str = "+I" then - Scomplex { Complex.re = 0.0; Complex.im = 1.0; } - else if str = "-i" || str = "-I" then - Scomplex { Complex.re = 0.0; Complex.im = -1.0; } - else - let s = { s_str = str; s_pos = 0 } in - let (base, ex) = - match parse_prefix s with - 0, x -> if ub = 0 then (10, x) else (ub, x) - | (b, x) as r -> - if ub <> 0 && ub <> b then - raise (Error "Base mismatch") - else r - in - let getn () = - if base = 10 && ex <> Exact then - begin - let sp = s.s_pos in - try - parse_num s 10 - with _ -> - s.s_pos <- sp; - parse_flo10 s - end - else - parse_num s base - and fixex n = - match (ex, n) with - (Inexact, (Sint _ | Sbigint _ | Srational _)) -> promote_real n - | (Exact, (Sreal _ | Scomplex _)) -> raise (Error "Not exact") - | _ -> n - in - let a = fixex (getn ()) in - match speek s with - Some ('+' | '-' as c) -> - if ex = Exact then - raise (Error "Complex not exact") - else - if ssleft s = 2 && s.s_str.[s.s_pos + 1] = 'i' then - Scomplex { Complex.re = float_of_snum a; - Complex.im = (if c = '-' then -1.0 else 1.0) } - else - let b = getn () in - if ssleft s <> 1 || speek s <> Some 'i' then - raise (Error "invalid number") - else - Scomplex { Complex.re = float_of_snum a; - Complex.im = float_of_snum b } - | Some '@' -> - skip s; - if ex = Exact then - raise (Error "Complex not exact") - else - let b = getn () in - if ssleft s <> 0 then - raise (Error "invalid number") - else - let r = float_of_snum a - and t = float_of_snum b in - Scomplex (Complex.polar r t) - | Some c -> raise (Error "invalid number") - | None -> a -;; - -let snum_strtonum av = - match Array.length av with - (1 | 2) as n -> - let r = - if n = 2 then - begin - match av.(1) with - Sint i -> i - | _ -> raise (Error "string->number: invalid radix") - end - else - 0 - in - begin - match av.(0) with - Sstring s -> - begin - try - if s = "" then - Sfalse - else - string_to_num s r - with - _ -> Sfalse - end - | _ -> raise (Error "string->number: not a string") - end - | _ -> raise (Error "string->number: wrong number of args") -;; - -let string_of_real_s r = - let rec loop n = - let s = Printf.sprintf "%.*g" n r in - if n >= 25 || r = float_of_string s then s - else loop (n + 1) - in - loop 14 -;; - -let string_of_real r = - let s = string_of_real_s r in - let n = String.length s in - let rec loop i = - if i >= n then s ^ ".0" - else if s.[i] = '.' || s.[i] = 'e' then s - else loop (i + 1) - in - loop 0 -;; - -let string_of_complex = - function { Complex.re = r; Complex.im = i } -> - (string_of_real_s r) ^ - (if i < 0.0 then - begin - if i = -1.0 then - "-i" - else - (string_of_real_s i) ^ "i" - end - else - if i = 1.0 then - "+i" - else - "+" ^ (string_of_real_s i) ^ "i") -;; - -let ichr i = - if i < 10 then - char_of_int (int_of_char '0' + i) - else - char_of_int (int_of_char 'a' + i - 10) -;; - -let string_of_list l = - let n = List.length l in - let s = String.create n in - let rec loop i l = - if i < n then - begin - match l with - c::t -> s.[i] <- c; loop (i + 1) t - | _ -> assert false - end - else - () - in - loop 0 l; s -;; - -let itostr base i = - if i = 0 then - "0" - else - let pf = if i < 0 then "-" else "" in - let rec loop i r = - if i = 0 then - r - else - loop (i / base) ((ichr (i mod base))::r) - in - pf ^ string_of_list (loop (abs i) []) -;; - -let biqmi bi i = - let (q, r) = quomod_big_int bi (big_int_of_int i) in - (q, int_of_big_int r) -;; - -let bitostr base bi = - let pf = if sign_big_int bi < 0 then "-" else "" in - let rec loop bi r = - if sign_big_int bi = 0 then - begin - match r with - [] -> [ '0' ] - | _ -> r - end - else - let (q, m) = biqmi bi base in - loop q ((ichr m)::r) - in - pf ^ string_of_list (loop (abs_big_int bi) []) -;; - -let ntostr base = - function - Sint i -> itostr base i - | Sbigint bi -> bitostr base bi - | Srational r -> bitostr base (numerator_ratio r) ^ "/" ^ - bitostr base (denominator_ratio r) - | _ -> raise (Error "number->string: invalid radix for inexact number") -;; - -let rec snum_numtostr = - function - [| Sint i |] -> Sstring (string_of_int i) - | [| Sbigint bi |] -> Sstring (string_of_big_int bi) - | [| Srational r |] -> Sstring (string_of_ratio r) - | [| Sreal r |] -> Sstring (string_of_real r) - | [| Scomplex z |] -> Sstring (string_of_complex z) - | [| snum; Sint radix |] -> - if radix = 10 then - snum_numtostr [| snum |] - else if radix = 2 || radix = 8 || radix = 16 then - Sstring (ntostr radix snum) - else - raise (Error "number->string: invalid radix") - | _ -> raise (Error "number->string: bad args") -;; - -let init e = - set_pfn e snum_strtonum "string->number"; - set_pfn e snum_numtostr "number->string"; -;; - diff --git a/ocs-1.0.3/src/ocs_numstr.mli b/ocs-1.0.3/src/ocs_numstr.mli deleted file mode 100644 index 287fe4d..0000000 --- a/ocs-1.0.3/src/ocs_numstr.mli +++ /dev/null @@ -1,11 +0,0 @@ -(* Conversions between numbers and strings. *) - -open Ocs_types - -val string_of_real : float -> string -val string_of_complex : Complex.t -> string - -val string_to_num : string -> int -> sval - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_port.ml b/ocs-1.0.3/src/ocs_port.ml deleted file mode 100644 index a47887d..0000000 --- a/ocs-1.0.3/src/ocs_port.ml +++ /dev/null @@ -1,128 +0,0 @@ -(* Buffered I/O, Scheme ports. *) - -open Ocs_error - -type port = - | Input_channel of in_channel * char option ref - | Output_channel of out_channel - | Input_string of (string * int ref) * char option ref - | Output_string of Buffer.t - -let is_input p = - match p with - | Input_string _ - | Input_channel _ -> true - | _ -> false - -let is_output p = - match p with - | Output_string _ - | Output_channel _ -> true - | _ -> false - -let getc p = - match p with - | Input_channel (_, ({contents = Some c} as ungot)) - | Input_string (_, ({contents = Some c} as ungot)) -> - ungot := None; - Some c - | Input_channel (chan, {contents = None}) -> - begin - try - Some (input_char chan) - with End_of_file -> - None - end - | Input_string ((str, pos), {contents = None}) -> - if !pos >= (String.length str) then - None - else - let c = str.[!pos] in - pos := !pos + 1; - Some c - | _ -> - None - -let flush p = - match p with - | Output_channel chan -> - Pervasives.flush chan - | _ -> - () - -let close p = - match p with - | Input_channel (chan, ungot) -> - ungot := None; - close_in chan - | Output_channel chan -> - close_out chan - | _ -> - () - -let ungetc p c = - match p with - | Input_channel (_, ungot) - | Input_string (_, ungot) -> - ungot := Some c - | _ -> - () - -let char_ready p = - match p with - | Input_string (_, {contents = Some _}) - | Input_channel (_, {contents = Some _}) -> - true - | Input_string ((str, pos), {contents = None}) -> - !pos < (String.length str) - | Input_channel (chan, {contents = None}) -> - let fd = Unix.descr_of_in_channel chan in - let (r, _, _) = Unix.select [fd] [] [] 0.0 in - List.length r > 0 - | _ -> - false - -let putc p c = - match p with - | Output_string buf -> - Buffer.add_char buf c - | Output_channel chan -> - output_char chan c - | _ -> - () - -let puts p s = - match p with - | Output_string buf -> - Buffer.add_string buf s - | Output_channel chan -> - output_string chan s - | _ -> - () - -let input_port ch = Input_channel (ch, ref None) - -let output_port ch = Output_channel ch - -let open_input_port name = - try - input_port (open_in_bin name) - with Sys_error err -> - raise (Error ("unable to open '" ^ name ^ "' for input: " ^ err)) - -let open_output_port name = - try - output_port (open_out_bin name) - with Sys_error err -> - raise (Error ("unable to open '" ^ name ^ "' for output: " ^ err)) - -let open_input_string s = Input_string ((s, ref 0), ref None) - -let open_output_string () =Output_string (Buffer.create 256) - -let get_output_string p = - match p with - | Output_string buf -> - Buffer.contents buf - | _ -> - "" diff --git a/ocs-1.0.3/src/ocs_port.mli b/ocs-1.0.3/src/ocs_port.mli deleted file mode 100644 index 5345c3a..0000000 --- a/ocs-1.0.3/src/ocs_port.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Buffered I/O, Scheme ports. *) - -type port - -val input_port : in_channel -> port -val output_port : out_channel -> port -val open_input_port : string -> port -val open_output_port : string -> port -val open_input_string : string -> port -val open_output_string : unit -> port -val get_output_string : port -> string - -val is_input : port -> bool -val is_output : port -> bool - -val getc : port -> char option -val ungetc : port -> char -> unit -val char_ready : port -> bool - -val putc : port -> char -> unit -val puts : port -> string -> unit - -val flush : port -> unit - -val close : port -> unit - diff --git a/ocs-1.0.3/src/ocs_prim.ml b/ocs-1.0.3/src/ocs_prim.ml deleted file mode 100644 index 8ec6eec..0000000 --- a/ocs-1.0.3/src/ocs_prim.ml +++ /dev/null @@ -1,269 +0,0 @@ -(* Various primitives *) - -open Ocs_types -open Ocs_error -open Ocs_env -open Ocs_eval -open Ocs_misc -open Ocs_sym -open Ocs_io -open Ocs_compile -open Ocs_macro - -let logical_not = - function - Sfalse -> Strue - | _ -> Sfalse -;; - -(* Type predicates *) - -let is_boolean = - function - Strue | Sfalse -> Strue - | _ -> Sfalse -;; - -let is_string = - function - Sstring _ -> Strue - | _ -> Sfalse -;; - -let is_char = - function - Schar _ -> Strue - | _ -> Sfalse -;; - -let is_pair = - function - Spair _ -> Strue - | _ -> Sfalse -;; - -let is_null = - function - Snull -> Strue - | _ -> Sfalse -;; - -let is_vector = - function - Svector _ -> Strue - | _ -> Sfalse -;; - -let is_proc = - function - Sproc (_, _) | Sprim _ -> Strue - | _ -> Sfalse -;; - -let is_port = - function - Sport _ -> Strue - | _ -> Sfalse -;; - -let is_symbol = - function - Ssymbol _ -> Strue - | _ -> Sfalse -;; - -let symbol_to_string = - function - Ssymbol s -> Sstring s - | _ -> raise (Error "symbol->string: not a symbol") -;; - -let string_to_symbol = - function - Sstring s -> get_symbol (String.copy s) - | _ -> raise (Error "string->symbol: not a string") -;; - -let is_eq a b = - if a == b then Strue else Sfalse -;; - -let is_eqv a b = - if test_eqv a b then Strue else Sfalse -;; - -let is_equal a b = - if test_equal a b then Strue else Sfalse -;; - -let do_apply th cc av = - let n = Array.length av in - if n < 1 then - raise (Error "apply: bad args") - else - let f = av.(0) in - let rec loop i r = - if i = 0 then - r - else if i = n - 1 then (* r must be [] *) - loop (i - 1) (list_to_caml av.(i)) - else - loop (i - 1) (av.(i)::r) - in - let args = Array.map (fun x -> Cval x) - (Array.of_list (loop (n - 1) [])) - in - eval th cc (mkapply (Cval f) args) -;; - -let force _ cc = - function - [| Spromise ({ promise_code = c; - promise_val = None; - promise_th = Some th } as p) |] -> - eval th - (fun v -> - match p.promise_val with (* Computed before returning? *) - Some v -> cc v - | None -> - p.promise_val <- Some v; - p.promise_th <- None; (* Release reference for gc *) - cc v) c - | [| Spromise { promise_code = _; - promise_val = Some v; - promise_th = _ } |] -> - cc v - | _ -> raise (Error "force: bad args") -;; - -let map_for_each th cc av is_map = - let my_name = if is_map then "map" else "for-each" - and na = Array.length av - 1 in - if na <= 0 then - raise (Error (my_name ^ ": bad args")); - let proc = av.(0) - and get_cdr = - function - Spair { car = _; cdr = t } -> t - | _ -> raise (Error (my_name ^ ": list lengths don't match")) - and get_carc = - function - Spair { car = h; cdr = _ } -> Cval h - | _ -> raise (Error (my_name ^ ": list lengths don't match")) - and result = ref (if is_map then Snull else Sunspec) - and rtail = ref Snull in - let append v = - if !rtail == Snull then - begin - result := Spair { car = v; cdr = Snull }; - rtail := !result; - end - else - begin - match !rtail with - Spair p -> - p.cdr <- Spair { car = v; cdr = Snull }; - rtail := p.cdr - | _ -> assert false - end - in - let rec loop args = - match args.(0) with - Snull -> cc !result - | Spair _ -> - eval th - (fun v -> - if is_map then append v; - loop (Array.map get_cdr args)) - (mkapply (Cval proc) (Array.map get_carc args)) - | _ -> raise (Error (my_name ^ ": invalid argument lists")) - in - loop (Array.sub av 1 na) -;; - -let map th cc av = - map_for_each th cc av true -;; - -let for_each th cc av = - map_for_each th cc av false -;; - -let load_file e th name = - let th = { th with th_display = [| |]; th_depth = -1 } - and inp = Ocs_port.open_input_port name in - let lex = Ocs_lex.make_lexer inp name in - let rec loop () = - match Ocs_read.read_expr lex with - Seof -> () - | v -> - let c = compile e v in - eval th (fun _ -> ()) c; - loop () - in - loop () -;; - -let load_prim e th cc = - function - [| Sstring name |] -> load_file e th name; cc Sunspec - | _ -> raise (Error "load: invalid name argument") -;; - -let eval_prim th cc = - function - [| expr; Sesym (e, _) |] -> - eval { th with th_display = [| |]; th_depth = -1 } cc - (compile e expr) - | _ -> raise (Error "eval: invalid args") -;; - -let report_env e _ = - Sesym (env_copy e, Ssymbol "") -;; - -let null_env _ = - let e = top_env () in - bind_lang e; - bind_macro e; - Sesym (e, Ssymbol "") -;; - -let interact_env e = - fun () -> Sesym (e, Ssymbol "") -;; - -let init e = - set_pf1 e logical_not "not"; - set_pf1 e is_boolean "boolean?"; - set_pf1 e is_string "string?"; - set_pf1 e is_char "char?"; - set_pf1 e is_vector "vector?"; - set_pf1 e is_pair "pair?"; - set_pf1 e is_null "null?"; - set_pf1 e is_proc "procedure?"; - set_pf1 e is_port "port?"; - set_pf1 e is_symbol "symbol?"; - - set_pf1 e symbol_to_string "symbol->string"; - set_pf1 e string_to_symbol "string->symbol"; - - set_pf2 e is_eq "eq?"; - set_pf2 e is_eqv "eqv?"; - set_pf2 e is_equal "equal?"; - - set_pfcn e do_apply "apply"; - - set_pfcn e force "force"; - - set_pfcn e map "map"; - set_pfcn e for_each "for-each"; - - set_pfcn e (load_prim e) "load"; - set_pfcn e eval_prim "eval"; - - set_pf1 e (report_env (env_copy e)) "scheme-report-environment"; - set_pf1 e null_env "null-environment"; - set_pf0 e (interact_env e) "interaction-environment"; -;; - diff --git a/ocs-1.0.3/src/ocs_prim.mli b/ocs-1.0.3/src/ocs_prim.mli deleted file mode 100644 index b8f4a6d..0000000 --- a/ocs-1.0.3/src/ocs_prim.mli +++ /dev/null @@ -1,8 +0,0 @@ -(* Miscellaneous primitives. *) - -open Ocs_types - -val load_file : env -> thread -> string -> unit - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_print.ml b/ocs-1.0.3/src/ocs_print.ml deleted file mode 100644 index e2f5671..0000000 --- a/ocs-1.0.3/src/ocs_print.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* Print Scheme values *) - -open Ocs_types -open Ocs_sym -open Ocs_numstr - -let write_string p s = - Ocs_port.putc p '\"'; - for i = 0 to String.length s - 1 do - match s.[i] with - '\n' -> Ocs_port.puts p "\\n" - | '\r' -> Ocs_port.puts p "\\r" - | '\t' -> Ocs_port.puts p "\\t" - | '\\' -> Ocs_port.puts p "\\\\" - | '\"' -> Ocs_port.puts p "\\\"" - | '\032' .. '\126' as c -> Ocs_port.putc p c - | c -> Ocs_port.puts p (Printf.sprintf "\\x%02x" (int_of_char c)) - done; - Ocs_port.putc p '\"' -;; - -let write_char p c = - Ocs_port.puts p "#\\"; - match c with - '\033' .. '\126' -> Ocs_port.putc p c - | _ -> Ocs_port.puts p (Ocs_char.char_to_name c) -;; - -let rec write_vector p disp v = - Ocs_port.puts p "#("; - for i = 0 to Array.length v - 1 do - if i <> 0 then Ocs_port.putc p ' '; - print p disp v.(i) - done; - Ocs_port.putc p ')' - -and write_list p disp l = - Ocs_port.putc p '('; - let rec pit l = - print p disp l.car; - match l.cdr with - Snull -> () - | Spair t -> Ocs_port.putc p ' '; pit t - | x -> Ocs_port.puts p " . "; print p disp x - in - pit l; - Ocs_port.putc p ')' - -and print p disp = - function - Snull -> Ocs_port.puts p "()" - | Seof -> Ocs_port.puts p "#" - | Strue -> Ocs_port.puts p "#t" - | Sfalse -> Ocs_port.puts p "#f" - | Sstring s -> if disp then Ocs_port.puts p s else write_string p s - | Ssymbol s -> Ocs_port.puts p s - | Sint i -> Ocs_port.puts p (string_of_int i) - | Sreal r -> Ocs_port.puts p (string_of_real r) - | Scomplex z -> Ocs_port.puts p (string_of_complex z) - | Sbigint b -> Ocs_port.puts p (Big_int.string_of_big_int b) - | Srational r -> Ocs_port.puts p (Ratio.string_of_ratio r) - | Schar c -> if disp then Ocs_port.putc p c else write_char p c - | Spair l -> write_list p disp l - | Svector v -> write_vector p disp v - | Sport _ -> Ocs_port.puts p "#" - | Sproc _ -> Ocs_port.puts p "#" - | Sprim { prim_fun = _; prim_name = n } -> - Ocs_port.puts p "#' - | Spromise _ -> Ocs_port.puts p "#" - | Sesym (_, s) -> print p disp s - | Swrapped _ -> Ocs_port.puts p "#" - | Sunspec -> Ocs_port.puts p "#" - | _ -> Ocs_port.puts p "#" -;; - diff --git a/ocs-1.0.3/src/ocs_print.mli b/ocs-1.0.3/src/ocs_print.mli deleted file mode 100644 index 15e52ed..0000000 --- a/ocs-1.0.3/src/ocs_print.mli +++ /dev/null @@ -1,9 +0,0 @@ -(* Print Scheme values *) - -open Ocs_types - -val write_string : Ocs_port.port -> string -> unit -val write_char : Ocs_port.port -> char -> unit - -val print : Ocs_port.port -> bool -> sval -> unit - diff --git a/ocs-1.0.3/src/ocs_read.ml b/ocs-1.0.3/src/ocs_read.ml deleted file mode 100644 index 5f32326..0000000 --- a/ocs-1.0.3/src/ocs_read.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* Reader of Scheme expressions. *) - -open Ocs_types -open Ocs_error -open Ocs_lex -open Ocs_sym -open Ocs_misc - -let read_error lex err = - let (file, name) = get_loc lex in - if String.length file = 0 then - Error err - else - ErrorL ((file, name), err) -;; - -let show_token = - function - '"' -> "'\"'" - | '\032' .. '\126' as c -> Printf.sprintf "\"%c\"" c - | c -> Printf.sprintf "ascii %d" (int_of_char c) -;; - -let rec read_item lex = - function - Leof -> Seof - | Lident s -> get_symbol (String.lowercase s) - | Lstring s -> Sstring s - | Lnumber s | Lbool s | Lchar s -> s - | Ltoken '(' -> read_list lex ')' - | Ltoken '[' -> read_list lex ']' - | Lopenv -> read_vector lex - | Ltoken '\'' -> read_quoted lex sym_quote - | Ltoken '`' -> read_quoted lex sym_quasiquote - | Ltoken ',' -> read_quoted lex sym_unquote - | Lunqsplice -> read_quoted lex sym_unquote_splicing - | Ltoken c -> raise (read_error lex ("unexpected " ^ show_token c)) - -and read_list lex term = - let rec loop r = - match get_tok lex with - Leof -> raise (read_error lex "unexpected eof in list") - | Ltoken c when c = term -> make_slist Snull r - | Ltoken '.' -> - begin - let tl = - match get_tok lex with - Leof -> raise (read_error lex "unexpected eof in dotted tail") - | x -> read_item lex x - in - match get_tok lex with - Ltoken c when c = term -> make_slist tl r - | _ -> raise (read_error lex - "expected close paren after dotted tail") - end - | x -> loop ((read_item lex x)::r) - in - loop [] - -and read_vector lex = - let rec loop r = - match get_tok lex with - Leof -> raise (read_error lex "unexpected eof in vector") - | Ltoken ')' -> r - | x -> loop ((read_item lex x)::r) - in - Svector (Array.of_list (List.rev (loop []))) - -and read_quoted lex sym = - match get_tok lex with - Leof -> raise (read_error lex "unexpected eof") - | x -> - let x = read_item lex x in - Spair { car = sym; cdr = Spair { car = x; cdr = Snull }} -;; - -let read_expr lex = - read_item lex (get_tok lex) -;; - -let read_from_port p = - read_expr (make_lexer p "") -;; - -let read_from_string s = - read_from_port (Ocs_port.open_input_string s) -;; diff --git a/ocs-1.0.3/src/ocs_read.mli b/ocs-1.0.3/src/ocs_read.mli deleted file mode 100644 index e65bdac..0000000 --- a/ocs-1.0.3/src/ocs_read.mli +++ /dev/null @@ -1,10 +0,0 @@ -(* Reader of Scheme expressions. *) - -open Ocs_types -open Ocs_lex - -val read_expr : lexer -> sval - -val read_from_port : Ocs_port.port -> sval -val read_from_string : string -> sval - diff --git a/ocs-1.0.3/src/ocs_string.ml b/ocs-1.0.3/src/ocs_string.ml deleted file mode 100644 index 2330900..0000000 --- a/ocs-1.0.3/src/ocs_string.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* String primitives *) - -open Ocs_types -open Ocs_error -open Ocs_env - -let make_string = - function - [| Sint k |] -> Sstring (String.create k) - | [| Sint k; Schar c |] -> Sstring (String.make k c) - | _ -> raise (Error "make-string: bad args") -;; - -let string_of av = - let n = Array.length av in - let s = String.create n in - for i = 0 to n - 1 do - match av.(i) with - Schar c -> s.[i] <- c - | _ -> raise (Error "string: bad args") - done; - Sstring s -;; - -let string_length = - function - Sstring s -> Sint (String.length s) - | _ -> raise (Error "string-length: not a string") -;; - -let string_ref s k = - match (s, k) with - (Sstring s, Sint k) -> - if k >= 0 && k < String.length s then - Schar s.[k] - else - raise (Error "string-ref: out of bounds") - | _ -> raise (Error "string-ref: bad args") -;; - -let string_set s k c = - match (s, k, c) with - (Sstring s, Sint k, Schar c) -> - if k >= 0 && k < String.length s then - begin - s.[k] <- c; Sunspec - end - else - raise (Error "string-set!: out of bounds") - | _ -> raise (Error "string-set!: bad args") -;; - -let string_cmp op s1 s2 = - match (s1, s2) with - (Sstring s1, Sstring s2) -> if op s1 s2 then Strue else Sfalse - | _ -> raise (Error "bad args") -;; - -let string_eq = string_cmp (=);; -let string_lt = string_cmp (<);; -let string_gt = string_cmp (>);; -let string_le = string_cmp (<=);; -let string_ge = string_cmp (>=);; - -let string_ci_cmp op s1 s2 = - match (s1, s2) with - (Sstring s1, Sstring s2) -> - if op (String.lowercase s1) (String.lowercase s2) then Strue else Sfalse - | _ -> raise (Error "bad args") -;; - -let string_ci_eq = string_ci_cmp (=);; -let string_ci_lt = string_ci_cmp (<);; -let string_ci_gt = string_ci_cmp (>);; -let string_ci_le = string_ci_cmp (<=);; -let string_ci_ge = string_ci_cmp (>=);; - -let string_append av = - Sstring - (Array.fold_left (^) "" - (Array.map (function - Sstring s -> s - | _ -> raise (Error "string-append: bad args")) av)) -;; - -let substring s sp ep = - match (s, sp, ep) with - (Sstring s, Sint sp, Sint ep) -> - let n = String.length s in - if sp >= 0 && sp <= ep && ep <= n then - Sstring (String.sub s sp (ep - sp)) - else - raise (Error "substring: out of bounds") - | _ -> raise (Error "substring: bad args") -;; - -let string_to_list = - function - Sstring s -> - begin - let rec loop i r = - if i < 0 then r - else loop (i - 1) (Spair { car = Schar s.[i]; cdr = r }) - in - loop (String.length s - 1) Snull - end - | _ -> raise (Error "string->list: not a string") -;; - -let string_copy = - function - Sstring s -> Sstring (String.copy s) - | _ -> raise (Error "string-copy: not a string") -;; - -let string_fill s c = - match (s, c) with - (Sstring s, Schar c) -> - String.fill s 0 (String.length s) c; Sunspec - | _ -> raise (Error "string-fill!: bad args") -;; - -let init e = - set_pfn e make_string "make-string"; - set_pfn e string_of "string"; - - set_pf1 e string_length "string-length"; - - set_pf2 e string_ref "string-ref"; - set_pf3 e string_set "string-set!"; - - set_pf2 e string_eq "string=?"; - set_pf2 e string_lt "string?"; - set_pf2 e string_le "string<=?"; - set_pf2 e string_ge "string>=?"; - - set_pf2 e string_ci_eq "string-ci=?"; - set_pf2 e string_ci_lt "string-ci?"; - set_pf2 e string_ci_le "string-ci<=?"; - set_pf2 e string_ci_ge "string-ci>=?"; - - set_pf3 e substring "substring"; - - set_pfn e string_append "string-append"; - - set_pf1 e string_to_list "string->list"; - - set_pf1 e string_copy "string-copy"; - - set_pf2 e string_fill "string-fill!"; -;; diff --git a/ocs-1.0.3/src/ocs_string.mli b/ocs-1.0.3/src/ocs_string.mli deleted file mode 100644 index 7c7287a..0000000 --- a/ocs-1.0.3/src/ocs_string.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* String primitives *) - -open Ocs_types - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_sym.ml b/ocs-1.0.3/src/ocs_sym.ml deleted file mode 100644 index 62139ef..0000000 --- a/ocs-1.0.3/src/ocs_sym.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* Symbol table implementation. *) - -open Ocs_types -open Ocs_error - -(* Symbols are stored in a hash table of weak references. This - guarantees that they are unique, but they needn't be permanent. *) - -module HashSymbol = - struct - type t = sval - let equal a b = - match (a, b) with - (Ssymbol s1, Ssymbol s2) -> s1 = s2 - | _ -> false - let hash = Hashtbl.hash - end - -module SymTable = Weak.Make (HashSymbol) - -let symt = SymTable.create 307 - -let get_symbol s = - SymTable.merge symt (Ssymbol s) -;; - -let sym_name = - function - Ssymbol s -> s - | _ -> raise (Error "sym_name: not a symbol") -;; - -let sym_quote = get_symbol "quote" -let sym_lambda = get_symbol "lambda" -let sym_if = get_symbol "if" -let sym_set = get_symbol "set!" -let sym_begin = get_symbol "begin" -let sym_cond = get_symbol "cond" -let sym_and = get_symbol "and" -let sym_or = get_symbol "or" -let sym_case = get_symbol "case" -let sym_let = get_symbol "let" -let sym_letstar = get_symbol "let*" -let sym_letrec = get_symbol "letrec" -let sym_do = get_symbol "do" -let sym_delay = get_symbol "delay" -let sym_quasiquote = get_symbol "quasiquote" -let sym_else = get_symbol "else" -let sym_arrow = get_symbol "=>" -let sym_define = get_symbol "define" -let sym_unquote = get_symbol "unquote" -let sym_unquote_splicing = get_symbol "unquote-splicing" - -let sym_define_syntax = get_symbol "define-syntax" -let sym_let_syntax = get_symbol "let-syntax" -let sym_letrec_syntax = get_symbol "letrec-syntax" -let sym_syntax_rules = get_symbol "syntax-rules" -let sym_ellipsis = get_symbol "..." - diff --git a/ocs-1.0.3/src/ocs_sym.mli b/ocs-1.0.3/src/ocs_sym.mli deleted file mode 100644 index f9a0d2f..0000000 --- a/ocs-1.0.3/src/ocs_sym.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Symbol table interface. *) - -open Ocs_types - -(* get_symbol returns a symbol corresponding to a string. It is - created if it doesn't exist. *) -val get_symbol : string -> sval -val sym_name : sval -> string - -(* Keywords are globally defined for convenience. *) -val sym_quote : sval -val sym_lambda : sval -val sym_if : sval -val sym_set : sval -val sym_begin : sval -val sym_cond : sval -val sym_and : sval -val sym_or : sval -val sym_case : sval -val sym_let : sval -val sym_letstar : sval -val sym_letrec : sval -val sym_do : sval -val sym_delay : sval -val sym_quasiquote : sval -val sym_else : sval -val sym_arrow : sval -val sym_define : sval -val sym_unquote : sval -val sym_unquote_splicing : sval - -val sym_define_syntax : sval -val sym_let_syntax : sval -val sym_letrec_syntax : sval -val sym_syntax_rules : sval -val sym_ellipsis : sval diff --git a/ocs-1.0.3/src/ocs_top.ml b/ocs-1.0.3/src/ocs_top.ml deleted file mode 100644 index 14fc07c..0000000 --- a/ocs-1.0.3/src/ocs_top.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* Top level, create and initialize the environment. *) - -open Ocs_types -open Ocs_error -open Ocs_env -open Ocs_compile -open Ocs_eval -open Ocs_print -open Ocs_macro - -(* Create a top-level environment and bind standard primitives. *) -let make_env () = - let e = top_env () in - bind_lang e; - bind_macro e; - Ocs_num.init e; - Ocs_numstr.init e; - Ocs_prim.init e; - Ocs_vector.init e; - Ocs_list.init e; - Ocs_char.init e; - Ocs_string.init e; - Ocs_contin.init e; - Ocs_io.init e; - e -;; - -(* Create a top-level thread. *) -let make_thread () = - { th_display = [| |]; - th_frame = [| |]; - th_depth = -1; - th_stdin = Sport (Ocs_port.input_port stdin); - th_stdout = Sport (Ocs_port.output_port stdout); - th_dynext = None } -;; - -let get_port = - function - Sport p -> p - | _ -> failwith "expected port" -;; - -(* Top-level loop for interaction. *) -let top_loop env th = - let inp = get_port th.th_stdin - and outp = get_port th.th_stdout - and errp = Ocs_port.output_port stderr in - let lex = Ocs_lex.make_lexer inp "" in - let rec loop () = - Ocs_port.puts outp "> "; - Ocs_port.flush outp; - try - match Ocs_read.read_expr lex with - Seof -> () - | v -> - let c = compile env v in - eval th (function Sunspec -> () - | r -> - print outp false r; - Ocs_port.putc outp '\n') c; - loop () - with Error err | ErrorL (_, err) -> - Ocs_port.puts errp ("Error: " ^ err ^ "\n"); - Ocs_port.flush errp; - loop () - in - loop () -;; - -(* Simple interface to invoke the interactive Scheme environment. *) -let interactive () = - top_loop (make_env ()) (make_thread ()) -;; - diff --git a/ocs-1.0.3/src/ocs_top.mli b/ocs-1.0.3/src/ocs_top.mli deleted file mode 100644 index 4280cb0..0000000 --- a/ocs-1.0.3/src/ocs_top.mli +++ /dev/null @@ -1,10 +0,0 @@ -(* Create and initialize top level environment. *) - -open Ocs_types - -val make_env : unit -> env -val make_thread : unit -> thread -val top_loop : env -> thread -> unit - -val interactive : unit -> unit - diff --git a/ocs-1.0.3/src/ocs_types.mli b/ocs-1.0.3/src/ocs_types.mli deleted file mode 100644 index 4203dff..0000000 --- a/ocs-1.0.3/src/ocs_types.mli +++ /dev/null @@ -1,200 +0,0 @@ -(* Main types used *) - -open Ocs_vartable - -(* We have to declare most types here to avoid cross-dependencies between - compilation units. *) - -type sval = - (* Global variables are set to Sunbound when referenced but not assigned. *) - Sunbound - - (* List terminator. *) - | Snull - - (* End-of-file indicator. *) - | Seof - - (* Boolean values. This is more compact than Sbool of bool. *) - | Strue - | Sfalse - - (* String object. *) - | Sstring of string - - (* Symbol type. Symbols should not be created directly, but using - Ocs_sym.get_symbol, which ensures that they are unique and can be - compared using ==. *) - | Ssymbol of string - - (* Numeric types. *) - | Sint of int - | Sreal of float - | Scomplex of Complex.t - | Sbigint of Big_int.big_int - | Srational of Ratio.ratio - - (* Character. *) - | Schar of char - - (* A pair (list element). *) - | Spair of spair - - (* Vector. *) - | Svector of sval array - - (* Port object. *) - | Sport of Ocs_port.port - - (* A closure created by combining the process reference with the - local environment at that point of execution. *) - | Sproc of sproc * sval array array - - (* Primitive function. *) - | Sprim of sprim - - (* Delayed expression. *) - | Spromise of spromise - - (* A set of values returned by the 'values' primitive, - deconstructed into multiple parameters by call-with-values. *) - | Svalues of sval array - - (* A symbol explicitly tied to an environment that defines its scope. - These symbols are generated by macro expansions and eliminated - prior to evaluation. *) - | Sesym of env * sval - - (* Wrapped values are stub functions that encapsulate external values - of unknown types. *) - | Swrapped of (unit -> unit) - - (* An unspecified value. *) - | Sunspec - - (* The actual type of a pair (cons cell). *) -and spair = - { - mutable car : sval; - mutable cdr : sval - } - - (* Primitive structure. *) -and sprim = - { - prim_fun : primf; - prim_name : string - } - - (* Primitive function types. *) -and primf = - (* Simple functional interface to primitives with a small, constant - number of arguments. *) - Pf0 of (unit -> sval) - | Pf1 of (sval -> sval) - | Pf2 of (sval -> sval -> sval) - | Pf3 of (sval -> sval -> sval -> sval) - - (* Functional interface to primitives with a variable number of arguments. *) - | Pfn of (sval array -> sval) - - (* Continuation-based interface to primitives, also includes the thread - and supports a variable number of arguments. *) - | Pfcn of (thread -> (sval -> unit) -> sval array -> unit) - - (* Procedure structure. *) -and sproc = - { - proc_body : code; - proc_nargs : int; - proc_has_rest : bool; - proc_frame_size : int; - mutable proc_name : string - } - - (* Delayed expression. *) -and spromise = - { - promise_code : code; - mutable promise_val : sval option; - mutable promise_th : thread option (* Copy of the thread state *) - } - - (* Code types are used to represent analyzed expressions prepared for - evaluation. *) -and code = - Cval of sval - | Cseq2 of code * code - | Cseq3 of code * code * code - | Cseqn of code array - | Cand2 of code * code - | Cand3 of code * code * code - | Candn of code array - | Cor2 of code * code - | Cor3 of code * code * code - | Corn of code array - | Cif of code * code * code - | Csetg of gvar * code - | Csetl of int * int * code - | Cdefine of gvar * code - | Cgetg of gvar - | Cgetl of int * int - | Capply0 of code - | Capply1 of code * code - | Capply2 of code * code * code - | Capply3 of code * code * code * code - | Capplyn of code * code array - | Clambda of sproc - | Cqqp of code * code - | Cqqv of code array - | Cqqvs of code list - | Cqqspl of code - | Ccond of (code * code) array - | Ccondspec of code - | Ccase of code * (sval array * code) array - | Cdelay of code - - (* Global variable slot. *) -and gvar = - { - mutable g_sym : sval; - mutable g_val : sval - } - - (* Thread state, used during evaluation. *) -and thread = - { - th_frame : sval array; (* Current local frame. *) - th_display : sval array array; (* Current display. *) - th_depth : int; (* Display depth. *) - th_stdin : sval; (* Default input port. *) - th_stdout : sval; (* Default output port. *) - th_dynext : dynext option (* Current dynamic extent. *) - } - - (* Bindings, used during analysis. *) -and vbind = - Vglob of gvar - | Vloc of int * int - | Vsyntax of (env -> sval array -> code) - | Vmacro of (env -> sval array -> sval) - | Vkeyword of string - - (* Environment, used during analysis. *) -and env = - { - env_depth : int; - env_vartable : vbind vartable; - env_frame_size : int ref; - mutable env_tagged : (env * sval * vbind) list - } - - (* Dynamic extents are associated with threads and continuations. *) -and dynext = - { - dynext_parent : dynext option; - dynext_depth : int; - dynext_before : thread * code; - dynext_after : thread * code - } - diff --git a/ocs-1.0.3/src/ocs_vartable.ml b/ocs-1.0.3/src/ocs_vartable.ml deleted file mode 100644 index 85f1943..0000000 --- a/ocs-1.0.3/src/ocs_vartable.ml +++ /dev/null @@ -1,65 +0,0 @@ -(* Utility type for variable binding tables. *) - -module VarTable = Map.Make (String) - -type 'a vartable = { - vt_global : 'a vartable option; - mutable vt_bindings : 'a VarTable.t -} - -let vt_create () = - { vt_global = None; - vt_bindings = VarTable.empty } -;; - -let vt_inherit vt = - { vt_global = - if vt.vt_global = None then Some vt - else vt.vt_global; - vt_bindings = vt.vt_bindings } -;; - -let vt_global vt = - vt.vt_global = None -;; - -let rec vt_copy vt vc = - { vt_global = - (match vt.vt_global with - Some t -> Some (vt_copy t vc) - | _ -> None); - vt_bindings = - VarTable.map vc vt.vt_bindings } -;; - -let var_insert vt key r = - vt.vt_bindings <- VarTable.add key r vt.vt_bindings -;; - -let rec var_find vt key = - try - Some (VarTable.find key vt.vt_bindings) - with - Not_found -> - begin - match vt.vt_global with - Some x -> var_find x key - | _ -> None - end -;; - -let rec var_get vt key mkvar = - try - VarTable.find key vt.vt_bindings - with - Not_found -> - begin - match vt.vt_global with - Some x -> var_get x key mkvar - | _ -> - let r = mkvar () in - var_insert vt key r; - r - end -;; - diff --git a/ocs-1.0.3/src/ocs_vartable.mli b/ocs-1.0.3/src/ocs_vartable.mli deleted file mode 100644 index 2c5b946..0000000 --- a/ocs-1.0.3/src/ocs_vartable.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* Utility type for variable binding tables. *) - -type 'a vartable - -val vt_create : unit -> 'a vartable -val vt_inherit : 'a vartable -> 'a vartable -val vt_global : 'a vartable -> bool -val vt_copy : 'a vartable -> ('a -> 'a) -> 'a vartable - -val var_insert : 'a vartable -> string -> 'a -> unit -val var_find : 'a vartable -> string -> 'a option -val var_get : 'a vartable -> string -> (unit -> 'a) -> 'a - diff --git a/ocs-1.0.3/src/ocs_vector.ml b/ocs-1.0.3/src/ocs_vector.ml deleted file mode 100644 index 5916f46..0000000 --- a/ocs-1.0.3/src/ocs_vector.ml +++ /dev/null @@ -1,79 +0,0 @@ -(* Vector primitives. *) - -open Ocs_types -open Ocs_error -open Ocs_env - -let get_int = - function - Sint i -> i - | _ -> raise (Error "bad arg types") - -let make_vector av = - match Array.length av with - (1 | 2) as n -> - let size = get_int av.(0) - and fill = if n = 2 then av.(1) else Snull in - Svector (Array.make size fill) - | _ -> raise (Error "make-vector: wrong number of args") - -let vector_of v = - Svector v -;; - -let vector_length = - function - Svector v -> Sint (Array.length v) - | _ -> raise (Error "vector-length: not a vector") -;; - -let vector_ref sv i = - match (sv, i) with - (Svector vec, Sint i) -> vec.(i) - | _ -> raise (Error "vector-ref: bad arg types") -;; - -let vector_set sv i v = - match (sv, i) with - (Svector vec, Sint i) -> vec.(i) <- v; Sunspec - | _ -> raise (Error "vector-set!: bad arg types") -;; - -let vector_to_list = - function - Svector v -> - begin - let rec loop i r = - if i < 0 then r - else loop (i - 1) (Spair { car = v.(i); cdr = r }) - in - loop (Array.length v - 1) Snull - end - | _ -> raise (Error "vector->list: bad args") -;; - -let vector_fill sv v = - match sv with - Svector vec -> - for i = 0 to Array.length vec - 1 do - vec.(i) <- v - done; - Sunspec - | _ -> raise (Error "vector-fill!: bad args") -;; - -let init e = - set_pfn e make_vector "make-vector"; - - set_pfn e vector_of "vector"; - - set_pf1 e vector_length "vector-length"; - - set_pf2 e vector_ref "vector-ref"; - set_pf3 e vector_set "vector-set!"; - - set_pf1 e vector_to_list "vector->list"; - - set_pf2 e vector_fill "vector-fill!"; -;; - diff --git a/ocs-1.0.3/src/ocs_vector.mli b/ocs-1.0.3/src/ocs_vector.mli deleted file mode 100644 index 4282981..0000000 --- a/ocs-1.0.3/src/ocs_vector.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* Vector primitives *) - -open Ocs_types - -val init : env -> unit - diff --git a/ocs-1.0.3/src/ocs_wrap.ml b/ocs-1.0.3/src/ocs_wrap.ml deleted file mode 100644 index 1680cd5..0000000 --- a/ocs-1.0.3/src/ocs_wrap.ml +++ /dev/null @@ -1,35 +0,0 @@ -(* Functor for creating wrap/unwrap functions *) - -open Ocs_types -open Ocs_error - -module Make(T: sig type t end) = - struct - type t = T.t - - exception E of t - - let wrap v = - Swrapped (fun () -> raise (E v)) - - let unwrap = - function - Swrapped f -> - (try - f (); - raise (Error "unwrap: internal error") - with E v -> v - | _ -> raise (Error "unwrap: wrong wrapped type")) - | _ -> raise (Error "unwrap: not a wrapped type") - - let try_unwrap = - function - Swrapped f -> - (try - f (); - None - with E v -> Some v - | _ -> None) - | _ -> None - end - diff --git a/plugin.ml b/plugin.ml new file mode 100644 index 0000000..f14d71e --- /dev/null +++ b/plugin.ml @@ -0,0 +1,24 @@ +type handler = Iobuf.t -> Command.t -> unit + +let handlers = ref [] + +let register handler = + handlers := !handlers @ [handler] + +let unregister handler = + handlers := List.filter ((<>) handler) !handlers + +let handle_command iobuf cmd = + let rec loop h = + match h with + | [] -> () + | handler :: tl -> + begin + try + handler iobuf cmd + with _ -> + () + end; + loop tl + in + loop !handlers diff --git a/plugin.mli b/plugin.mli new file mode 100644 index 0000000..e1380f9 --- /dev/null +++ b/plugin.mli @@ -0,0 +1,5 @@ +type handler = Iobuf.t -> Command.t -> unit + +val register : handler -> unit +val unregister : handler -> unit +val handle_command : Iobuf.t -> Command.t -> unit