giles
202ea9cf5f
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
compare is a host builtin returning -1/0/1 (Stdlib.compare semantics) deferred to host SX </>. List.sort is insertion-sort in OCaml: O(n²) but works correctly. List.stable_sort = sort. Tested: ascending int sort, descending via custom comparator (b - a), empty list, string sort.
331 lines
8.4 KiB
Plaintext
331 lines
8.4 KiB
Plaintext
;; lib/ocaml/runtime.sx — minimal OCaml stdlib slice, written in OCaml.
|
|
;;
|
|
;; Defines List and Option modules with the most-used functions. Loaded
|
|
;; on demand via `(ocaml-load-stdlib! env)` from eval.sx, which parses
|
|
;; this source through `ocaml-parse-program` and evaluates each decl,
|
|
;; threading the env so stdlib bindings become available to user code.
|
|
;;
|
|
;; What's here is intentionally minimal — Phase 6 grows this into the
|
|
;; full ~150-function slice. Everything is defined in OCaml syntax (not
|
|
;; SX) on purpose, both as substrate validation and as documentation.
|
|
|
|
(define ocaml-stdlib-src
|
|
"module List = struct
|
|
let rec length lst =
|
|
match lst with
|
|
| [] -> 0
|
|
| _ :: t -> 1 + length t
|
|
|
|
let rec rev_append xs acc =
|
|
match xs with
|
|
| [] -> acc
|
|
| h :: t -> rev_append t (h :: acc)
|
|
|
|
let rev xs = rev_append xs []
|
|
|
|
let rec map f lst =
|
|
match lst with
|
|
| [] -> []
|
|
| h :: t -> f h :: map f t
|
|
|
|
let rec filter p lst =
|
|
match lst with
|
|
| [] -> []
|
|
| h :: t -> if p h then h :: filter p t else filter p t
|
|
|
|
let rec fold_left f init lst =
|
|
match lst with
|
|
| [] -> init
|
|
| h :: t -> fold_left f (f init h) t
|
|
|
|
let rec fold_right f lst init =
|
|
match lst with
|
|
| [] -> init
|
|
| h :: t -> f h (fold_right f t init)
|
|
|
|
let rec append xs ys =
|
|
match xs with
|
|
| [] -> ys
|
|
| h :: t -> h :: append t ys
|
|
|
|
let rec iter f lst =
|
|
match lst with
|
|
| [] -> ()
|
|
| h :: t -> f h; iter f t
|
|
|
|
let rec mem x lst =
|
|
match lst with
|
|
| [] -> false
|
|
| h :: t -> if h = x then true else mem x t
|
|
|
|
let rec for_all p lst =
|
|
match lst with
|
|
| [] -> true
|
|
| h :: t -> if p h then for_all p t else false
|
|
|
|
let rec exists p lst =
|
|
match lst with
|
|
| [] -> false
|
|
| h :: t -> if p h then true else exists p t
|
|
|
|
let hd lst =
|
|
match lst with
|
|
| [] -> failwith \"List.hd: empty\"
|
|
| h :: _ -> h
|
|
|
|
let tl lst =
|
|
match lst with
|
|
| [] -> failwith \"List.tl: empty\"
|
|
| _ :: t -> t
|
|
|
|
let rec nth lst n =
|
|
match lst with
|
|
| [] -> failwith \"List.nth: out of range\"
|
|
| h :: t -> if n = 0 then h else nth t (n - 1)
|
|
|
|
let rec concat lst =
|
|
match lst with
|
|
| [] -> []
|
|
| h :: t -> append h (concat t)
|
|
|
|
let flatten = concat
|
|
|
|
let rec init n f =
|
|
if n = 0 then [] else
|
|
begin
|
|
let rec build i =
|
|
if i = n then [] else f i :: build (i + 1)
|
|
in build 0
|
|
end
|
|
|
|
let rec find_opt p lst =
|
|
match lst with
|
|
| [] -> None
|
|
| h :: t -> if p h then Some h else find_opt p t
|
|
|
|
let rec find p lst =
|
|
match find_opt p lst with
|
|
| None -> failwith \"List.find: not found\"
|
|
| Some x -> x
|
|
|
|
let rec partition p lst =
|
|
match lst with
|
|
| [] -> ([], [])
|
|
| h :: t ->
|
|
(match partition p t with
|
|
| (yes, no) ->
|
|
if p h then (h :: yes, no) else (yes, h :: no))
|
|
|
|
let rec mapi f lst =
|
|
begin
|
|
let rec go i xs =
|
|
match xs with
|
|
| [] -> []
|
|
| h :: t -> f i h :: go (i + 1) t
|
|
in go 0 lst
|
|
end
|
|
|
|
let rec iteri f lst =
|
|
begin
|
|
let rec go i xs =
|
|
match xs with
|
|
| [] -> ()
|
|
| h :: t -> f i h; go (i + 1) t
|
|
in go 0 lst
|
|
end
|
|
|
|
let rec assoc k lst =
|
|
match lst with
|
|
| [] -> failwith \"List.assoc: not found\"
|
|
| (k2, v) :: t -> if k = k2 then v else assoc k t
|
|
|
|
let rec assoc_opt k lst =
|
|
match lst with
|
|
| [] -> None
|
|
| (k2, v) :: t -> if k = k2 then Some v else assoc_opt k t
|
|
|
|
let rec sort cmp xs =
|
|
begin
|
|
let rec insert x ys =
|
|
match ys with
|
|
| [] -> [x]
|
|
| h :: t -> if cmp x h <= 0 then x :: ys else h :: insert x t
|
|
in
|
|
match xs with
|
|
| [] -> []
|
|
| h :: t -> insert h (sort cmp t)
|
|
end
|
|
|
|
let stable_sort = sort
|
|
end ;;
|
|
|
|
module Option = struct
|
|
let map f o =
|
|
match o with
|
|
| None -> None
|
|
| Some x -> Some (f x)
|
|
|
|
let bind o f =
|
|
match o with
|
|
| None -> None
|
|
| Some x -> f x
|
|
|
|
let value o default =
|
|
match o with
|
|
| None -> default
|
|
| Some x -> x
|
|
|
|
let get o =
|
|
match o with
|
|
| None -> failwith \"Option.get: None\"
|
|
| Some x -> x
|
|
|
|
let is_none o =
|
|
match o with
|
|
| None -> true
|
|
| Some _ -> false
|
|
|
|
let is_some o =
|
|
match o with
|
|
| None -> false
|
|
| Some _ -> true
|
|
|
|
let iter f o =
|
|
match o with
|
|
| None -> ()
|
|
| Some x -> f x
|
|
|
|
let fold none_v f o =
|
|
match o with
|
|
| None -> none_v
|
|
| Some x -> f x
|
|
|
|
let to_list o =
|
|
match o with
|
|
| None -> []
|
|
| Some x -> [x]
|
|
end ;;
|
|
|
|
module Result = struct
|
|
let map f r =
|
|
match r with
|
|
| Ok x -> Ok (f x)
|
|
| Error e -> Error e
|
|
|
|
let bind r f =
|
|
match r with
|
|
| Ok x -> f x
|
|
| Error e -> Error e
|
|
|
|
let is_ok r =
|
|
match r with
|
|
| Ok _ -> true
|
|
| Error _ -> false
|
|
|
|
let is_error r =
|
|
match r with
|
|
| Ok _ -> false
|
|
| Error _ -> true
|
|
|
|
let get_ok r =
|
|
match r with
|
|
| Ok x -> x
|
|
| Error _ -> failwith \"Result.get_ok: Error\"
|
|
|
|
let get_error r =
|
|
match r with
|
|
| Ok _ -> failwith \"Result.get_error: Ok\"
|
|
| Error e -> e
|
|
|
|
let map_error f r =
|
|
match r with
|
|
| Ok x -> Ok x
|
|
| Error e -> Error (f e)
|
|
|
|
let to_option r =
|
|
match r with
|
|
| Ok x -> Some x
|
|
| Error _ -> None
|
|
end ;;
|
|
|
|
module String = struct
|
|
let length s = _string_length s
|
|
let get s i = _string_get s i
|
|
let sub s i n = _string_sub s i n
|
|
let concat sep xs = _string_concat sep xs
|
|
let uppercase_ascii s = _string_upper s
|
|
let lowercase_ascii s = _string_lower s
|
|
let starts_with prefix s = _string_starts_with prefix s
|
|
end ;;
|
|
|
|
module Char = struct
|
|
let code c = _char_code c
|
|
let chr n = _char_chr n
|
|
let lowercase_ascii c = _string_lower c
|
|
let uppercase_ascii c = _string_upper c
|
|
end ;;
|
|
|
|
module Int = struct
|
|
let to_string i = _string_of_int i
|
|
let of_string s = _int_of_string s
|
|
let abs n = if n < 0 then 0 - n else n
|
|
let max a b = if a > b then a else b
|
|
let min a b = if a < b then a else b
|
|
end ;;
|
|
|
|
module Float = struct
|
|
let to_string f = _string_of_float f
|
|
end ;;
|
|
|
|
module Printf = struct
|
|
let sprintf fmt = fmt
|
|
let printf fmt = print_string fmt
|
|
end ;;
|
|
|
|
module Hashtbl = struct
|
|
let create n = _hashtbl_create n
|
|
let add t k v = _hashtbl_add t k v
|
|
let replace t k v = _hashtbl_replace t k v
|
|
let find_opt t k = _hashtbl_find_opt t k
|
|
let find t k =
|
|
match _hashtbl_find_opt t k with
|
|
| None -> failwith \"Hashtbl.find: not found\"
|
|
| Some v -> v
|
|
let mem t k = _hashtbl_mem t k
|
|
let length t = _hashtbl_length t
|
|
end")
|
|
|
|
(define ocaml-stdlib-loaded false)
|
|
(define ocaml-stdlib-env nil)
|
|
|
|
;; Build a stdlib env once, cache it. ocaml-run / ocaml-run-program both
|
|
;; layer the user program on top of this base env.
|
|
(define ocaml-load-stdlib!
|
|
(fn ()
|
|
(when (not ocaml-stdlib-loaded)
|
|
(let ((env (ocaml-empty-env)))
|
|
(begin
|
|
(define run-decl
|
|
(fn (decl)
|
|
(let ((tag (ocaml-tag-of decl)))
|
|
(cond
|
|
((= tag "module-def")
|
|
(let ((mn (nth decl 1)) (ds (nth decl 2)))
|
|
(let ((mv (ocaml-eval-module ds env)))
|
|
(set! env (ocaml-env-extend env mn mv)))))
|
|
((= tag "def")
|
|
(let ((nm (nth decl 1)) (ps (nth decl 2)) (rh (nth decl 3)))
|
|
(let ((v (if (= (len ps) 0)
|
|
(ocaml-eval rh env)
|
|
(ocaml-make-curried ps rh env))))
|
|
(set! env (ocaml-env-extend env nm v)))))))))
|
|
(let ((prog (ocaml-parse-program ocaml-stdlib-src)))
|
|
(begin
|
|
(define loop
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(begin (run-decl (first xs)) (loop (rest xs))))))
|
|
(loop (rest prog))
|
|
(set! ocaml-stdlib-env env)
|
|
(set! ocaml-stdlib-loaded true))))))))
|