rose-ash/lib/ocaml/runtime.sx

;; 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

     let rec combine xs ys =
       match xs with
       | [] -> (match ys with
                | [] -> []
                | _ -> failwith \"List.combine: unequal lengths\")
       | hx :: tx ->
         match ys with
         | [] -> failwith \"List.combine: unequal lengths\"
         | hy :: ty -> (hx, hy) :: combine tx ty

     let rec split lst =
       match lst with
       | [] -> ([], [])
       | (a, b) :: t ->
         (match split t with
          | (xs, ys) -> (a :: xs, b :: ys))

     let rec fold_left2 f acc xs ys =
       match xs with
       | [] -> (match ys with [] -> acc | _ -> failwith \"List.fold_left2: unequal\")
       | hx :: tx ->
         match ys with
         | [] -> failwith \"List.fold_left2: unequal\"
         | hy :: ty -> fold_left2 f (f acc hx hy) tx ty

     let rec iter2 f xs ys =
       match xs with
       | [] -> (match ys with [] -> () | _ -> failwith \"List.iter2: unequal\")
       | hx :: tx ->
         match ys with
         | [] -> failwith \"List.iter2: unequal\"
         | hy :: ty -> f hx hy; iter2 f tx ty

     let rec map2 f xs ys =
       match xs with
       | [] -> (match ys with [] -> [] | _ -> failwith \"List.map2: unequal\")
       | hx :: tx ->
         match ys with
         | [] -> failwith \"List.map2: unequal\"
         | hy :: ty -> f hx hy :: map2 f tx ty

     let rec take n xs =
       if n <= 0 then []
       else
         match xs with
         | [] -> []
         | h :: t -> h :: take (n - 1) t

     let rec drop n xs =
       if n <= 0 then xs
       else
         match xs with
         | [] -> []
         | _ :: t -> drop (n - 1) t

     let rec filter_map f xs =
       match xs with
       | [] -> []
       | h :: t ->
         match f h with
         | None -> filter_map f t
         | Some v -> v :: filter_map f t

     let rec flat_map f xs =
       match xs with
       | [] -> []
       | h :: t -> append (f h) (flat_map f t)

     let concat_map = flat_map
   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]

     let join oo =
       match oo with
       | None -> None
       | Some inner -> inner

     let to_result none_v o =
       match o with
       | None -> Error none_v
       | Some x -> Ok x

     let some x = Some x
     let none = None
   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

     let value r default =
       match r with
       | Ok x -> x
       | Error _ -> default

     let iter f r =
       match r with
       | Ok x -> f x
       | Error _ -> ()

     let fold ok_f err_f r =
       match r with
       | Ok x -> ok_f x
       | Error e -> err_f e
   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
     let ends_with suffix s = _string_ends_with suffix s
     let contains s sub = _string_contains s sub
     let trim s = _string_trim s
     let split_on_char c s = _string_split_on_char c s
     let replace_all s a b = _string_replace s a b
     let index_of s sub = _string_index_of s sub
     let make n c =
       let rec aux i acc = if i = 0 then acc else aux (i - 1) (acc ^ c) in
       aux n \"\"
     let init n f =
       let rec aux i acc =
         if i >= n then acc else aux (i + 1) (acc ^ f i)
       in
       aux 0 \"\"
     let map f s =
       let rec aux i acc =
         if i >= _string_length s then acc
         else aux (i + 1) (acc ^ f (_string_get s i))
       in
       aux 0 \"\"
   end ;;

   module Bytes = struct
     (* Thin alias of String — SX has no separate immutable byte type. *)
     let length s = String.length s
     let get s i = String.get s i
     let of_string s = s
     let to_string s = s
     let concat sep xs = String.concat sep xs
     let sub s i n = String.sub s i n
   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
     let is_digit c =
       let n = _char_code c in n >= 48 && n <= 57
     let is_lower c =
       let n = _char_code c in n >= 97 && n <= 122
     let is_upper c =
       let n = _char_code c in n >= 65 && n <= 90
     let is_alpha c = is_lower c || is_upper c
     let is_alnum c = is_alpha c || is_digit c
     let is_whitespace c =
       c = \" \" || c = \"\\t\" || c = \"\\n\" || c = \"\\r\"
   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
     let sqrt f = _float_sqrt f
     let sin f = _float_sin f
     let cos f = _float_cos f
     let pow a b = _float_pow a b
     let floor f = _float_floor f
     let ceil f = _float_ceil f
     let round f = _float_round f
     let pi = 3.141592653589793
   end ;;

   module Printf = struct
     let sprintf fmt = fmt
     let printf fmt = print_string fmt
   end ;;

   module Stack = struct
     let create () = ref []
     let push x s = s := x :: !s
     let pop s =
       match !s with
       | [] -> failwith \"Stack.pop: empty\"
       | h :: t -> s := t ; h
     let top s =
       match !s with
       | [] -> failwith \"Stack.top: empty\"
       | h :: _ -> h
     let is_empty s = !s = []
     let length s = List.length !s
     let clear s = s := []
   end ;;

   module Queue = struct
     (* Simple two-list amortized queue: (front, back). pop drains
        front; refill from rev back when front is empty. *)
     let create () = ref ([], [])
     let push x q =
       let p = !q in
       q := (List.append [] (match p with (f, b) -> f), x :: (match p with (_, b) -> b))
     let length q =
       let p = !q in
       let f = match p with (f, _) -> f in
       let b = match p with (_, b) -> b in
       List.length f + List.length b
     let is_empty q = length q = 0
     let pop q =
       let p = !q in
       let f = match p with (f, _) -> f in
       let b = match p with (_, b) -> b in
       match f with
       | h :: t -> q := (t, b) ; h
       | [] ->
         (match List.rev b with
          | [] -> failwith \"Queue.pop: empty\"
          | h :: t -> q := (t, []) ; h)
     let clear q = q := ([], [])
   end ;;

   module Buffer = struct
     let create _ = ref []
     let add_string b s = b := s :: !b
     let add_char b c = b := c :: !b
     let contents b = String.concat \"\" (List.rev !b)
     let length b = String.length (String.concat \"\" (List.rev !b))
     let clear b = b := []
     let reset = clear
   end ;;

   module Sys = struct
     let os_type = \"SX\"
     let word_size = 64
     let max_array_length = 4611686018427387903
     let max_string_length = 4611686018427387903
     let executable_name = \"ocaml-on-sx\"
     let big_endian = false
     let unix = true
     let win32 = false
     let cygwin = false
   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 ;;

   module Map = struct
     module Make (Ord) = struct
       let empty = []

       let rec add k v m =
         match m with
         | [] -> [(k, v)]
         | (k2, v2) :: rest ->
           begin
             let c = Ord.compare k k2 in
             if c = 0 then (k, v) :: rest
             else if c < 0 then (k, v) :: m
             else (k2, v2) :: add k v rest
           end

       let rec find_opt k m =
         match m with
         | [] -> None
         | (k2, v) :: rest ->
           if Ord.compare k k2 = 0 then Some v
           else find_opt k rest

       let find k m =
         match find_opt k m with
         | None -> failwith \"Map.find: not found\"
         | Some v -> v

       let rec mem k m =
         match m with
         | [] -> false
         | (k2, _) :: rest -> if Ord.compare k k2 = 0 then true else mem k rest

       let rec remove k m =
         match m with
         | [] -> []
         | (k2, v) :: rest ->
           if Ord.compare k k2 = 0 then rest else (k2, v) :: remove k rest

       let rec bindings m = m

       let rec cardinal m =
         match m with
         | [] -> 0
         | _ :: t -> 1 + cardinal t

       let rec iter f m =
         match m with
         | [] -> ()
         | (k, v) :: t -> f k v; iter f t

       let rec fold f m acc =
         match m with
         | [] -> acc
         | (k, v) :: t -> fold f t (f k v acc)

       let rec map f m =
         match m with
         | [] -> []
         | (k, v) :: t -> (k, f v) :: map f t

       let rec filter p m =
         match m with
         | [] -> []
         | (k, v) :: t ->
           if p k v then (k, v) :: filter p t else filter p t

       let rec is_empty m =
         match m with
         | [] -> true
         | _ -> false
     end
   end ;;

   module Set = struct
     module Make (Ord) = struct
       let empty = []

       let rec mem x s =
         match s with
         | [] -> false
         | h :: t ->
           let c = Ord.compare x h in
           if c = 0 then true
           else if c < 0 then false
           else mem x t

       let rec add x s =
         match s with
         | [] -> [x]
         | h :: t ->
           let c = Ord.compare x h in
           if c = 0 then s
           else if c < 0 then x :: s
           else h :: add x t

       let rec remove x s =
         match s with
         | [] -> []
         | h :: t ->
           if Ord.compare x h = 0 then t else h :: remove x t

       let rec elements s = s

       let rec cardinal s =
         match s with
         | [] -> 0
         | _ :: t -> 1 + cardinal t

       let rec iter f s =
         match s with
         | [] -> ()
         | h :: t -> f h; iter f t

       let rec fold f s acc =
         match s with
         | [] -> acc
         | h :: t -> fold f t (f h acc)

       let rec filter p s =
         match s with
         | [] -> []
         | h :: t -> if p h then h :: filter p t else filter p t

       let rec is_empty s =
         match s with
         | [] -> true
         | _ -> false

       let rec union a b =
         match b with
         | [] -> a
         | h :: t -> union (add h a) t

       let rec inter a b =
         match a with
         | [] -> []
         | h :: t -> if mem h b then h :: inter t b else inter t b
     end
   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))))))))