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 split lst =
           match lst with
           | [] -> ([], [])
           | [x] -> ([x], [])
           | x :: y :: rest ->
             (match split rest with
              | (a, b) -> (x :: a, y :: b))
         in
         let rec merge xs ys =
           match xs with
           | [] -> ys
           | x :: xs' ->
             (match ys with
              | [] -> xs
              | y :: ys' ->
                if cmp x y <= 0 then x :: merge xs' (y :: ys')
                else y :: merge (x :: xs') ys')
         in
         match xs with
         | [] -> []
         | [x] -> [x]
         | _ ->
           (match split xs with
            | (a, b) -> merge (sort cmp a) (sort cmp b))
       end

     let stable_sort = sort

     let rec sort_uniq cmp xs =
       let sorted = sort cmp xs in
       let rec dedup ys =
         match ys with
         | [] -> []
         | [x] -> [x]
         | a :: b :: rest ->
           if cmp a b = 0 then dedup (b :: rest)
           else a :: dedup (b :: rest)
       in
       dedup sorted

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

     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 \"\"
     let iter f s =
       let rec aux i =
         if i >= _string_length s then ()
         else (f (_string_get s i); aux (i + 1))
       in
       aux 0
     let iteri f s =
       let rec aux i =
         if i >= _string_length s then ()
         else (f i (_string_get s i); aux (i + 1))
       in
       aux 0
     let fold_left f init s =
       let rec aux i acc =
         if i >= _string_length s then acc
         else aux (i + 1) (f acc (_string_get s i))
       in
       aux 0 init
     let fold_right f s init =
       let rec aux i acc =
         if i < 0 then acc
         else aux (i - 1) (f (_string_get s i) acc)
       in
       aux (_string_length s - 1) init
     let to_seq s =
       let rec aux i =
         if i >= _string_length s then []
         else _string_get s i :: aux (i + 1)
       in
       aux 0
     let of_seq xs =
       let rec aux ys acc =
         match ys with
         | [] -> acc
         | h :: t -> aux t (acc ^ h)
       in
       aux xs \"\"
   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
     let max_int = 4611686018427387903
     let min_int = -4611686018427387904
     let zero = 0
     let one = 1
     let minus_one = -1
     let succ n = n + 1
     let pred n = n - 1
     let neg n = 0 - n
     let add a b = a + b
     let sub a b = a - b
     let mul a b = a * b
     let div a b = a / b
     let rem a b = a - b * (a / b)
     let equal a b = a = b
     let compare a b = if a < b then -1 else if a > b then 1 else 0
   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
     (* sprintf walks fmt, accumulating prefix. When it sees a %X
        spec, it returns a function of one arg that substitutes the
        arg and recurses on the rest of fmt. With no specs, returns
        the bare format string. Specs supported: %d %s %f %c %b
        (and %% as a literal). Unknown specs are passed through. *)
     let sprintf fmt =
       let n = _string_length fmt in
       let rec walk pos prefix =
         if pos >= n then prefix
         else if pos + 1 < n && _string_get fmt pos = \"%\" then
           let spec = _string_get fmt (pos + 1) in
           if spec = \"%\" then walk (pos + 2) (prefix ^ \"%\")
           else if spec = \"d\" || spec = \"i\" || spec = \"s\"
                || spec = \"f\" || spec = \"c\" || spec = \"b\"
                || spec = \"x\" || spec = \"X\" || spec = \"o\"
                || spec = \"u\" then
             (fun arg ->
                let s =
                  if spec = \"d\" || spec = \"i\" || spec = \"u\"
                    then _string_of_int arg
                  else if spec = \"f\" then _string_of_float arg
                  else if spec = \"x\" then _int_to_hex_lower arg
                  else if spec = \"X\" then _int_to_hex_upper arg
                  else if spec = \"o\" then _int_to_octal arg
                  else if spec = \"b\" then
                    (if arg then \"true\" else \"false\")
                  else arg
                in
                walk (pos + 2) (prefix ^ s))
           else walk (pos + 1) (prefix ^ _string_get fmt pos)
         else walk (pos + 1) (prefix ^ _string_get fmt pos)
       in
       walk 0 \"\"

     let printf fmt = sprintf fmt
   end ;;

   module Format = struct
     (* Thin alias of Printf for pretty-printing parity. The dynamic
        runtime doesn't distinguish boxes/breaks — fmt strings work
        the same as in Printf. *)
     let sprintf fmt = Printf.sprintf fmt
     let printf fmt = Printf.sprintf fmt
     let asprintf fmt = Printf.sprintf fmt
   end ;;

   module Lazy = struct
     let force lz = _lazy_force lz
   end ;;

   module Array = struct
     (* Backed by a ref-of-list. Mutating set! replaces the underlying
        list with a new one in which one cell is changed. O(n) set, but
        good enough for short arrays in baseline programs. *)
     let make n v =
       let rec build i acc =
         if i = 0 then acc else build (i - 1) (v :: acc)
       in
       ref (build n [])

     let length a = List.length !a
     let get a i = List.nth !a i

     let set a i v =
       let rec replace lst k =
         match lst with
         | [] -> []
         | h :: t -> if k = 0 then v :: t else h :: replace t (k - 1)
       in
       a := replace !a i

     let init n f =
       let rec build i acc =
         if i = 0 then acc else build (i - 1) (f (i - 1) :: acc)
       in
       ref (build n [])

     let iter f a = List.iter f !a
     let iteri f a = List.iteri f !a
     let map f a = ref (List.map f !a)
     let mapi f a = ref (List.mapi f !a)
     let fold_left f init a = List.fold_left f init !a
     let to_list a = !a
     let of_list xs = ref xs
     let copy a = ref !a
     let sort cmp a = a := List.sort cmp !a
     let stable_sort = sort
     let fast_sort = sort

     let append a b = ref (List.append !a !b)

     let sub a pos n =
       let rec take xs k =
         if k = 0 then []
         else match xs with
              | [] -> []
              | h :: t -> h :: take t (k - 1)
       in
       let rec drop xs k =
         if k = 0 then xs
         else match xs with
              | [] -> []
              | _ :: t -> drop t (k - 1)
       in
       ref (take (drop !a pos) n)

     let exists p a = List.exists p !a
     let for_all p a = List.for_all p !a
     let mem x a = List.mem x !a

     let blit src si dst di n =
       for k = 0 to n - 1 do
         set dst (di + k) (get src (si + k))
       done
     let fill a pos n v =
       for k = 0 to n - 1 do set a (pos + k) v done
   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

     (* iter / fold over (k, v) pairs. Keys come back as their string
        representation since the host coerces all keys via `str`. *)
     let iter f t =
       let rec go xs =
         match xs with
         | [] -> ()
         | (k, v) :: rest -> f k v; go rest
       in
       go (_hashtbl_to_list t)

     let fold f t acc =
       let rec go xs a =
         match xs with
         | [] -> a
         | (k, v) :: rest -> go rest (f k v a)
       in
       go (_hashtbl_to_list t) acc
   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 ;;

   let string_of_int n = _string_of_int n
   let string_of_float f = _string_of_float f
   let string_of_bool b = if b then \"true\" else \"false\"
   let int_of_string s = _int_of_string s
   let max_int = 4611686018427387903
   let min_int = -4611686018427387904
   let abs_float f = if f < 0.0 then 0.0 -. f else f
   let float_of_int n = n
   let int_of_float f = f
   ")

(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))))))))