spec: bytevectors (make-bytevector/u8-ref/u8-set!/utf8->string/etc)
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
@@ -2891,4 +2891,106 @@ let () =
|
||||
let r = !Sx_types._cek_call_ref fn (List [v]) in
|
||||
Hashtbl.replace out (set_key r) r) ht;
|
||||
SxSet out
|
||||
| _ -> raise (Eval_error "set-map: expected set fn"))
|
||||
| _ -> raise (Eval_error "set-map: expected set fn"));
|
||||
(* === Bytevectors === *)
|
||||
register "make-bytevector" (fun args ->
|
||||
match args with
|
||||
| [Integer n] -> SxBytevector (Bytes.make n '\000')
|
||||
| [Integer n; Integer fill] ->
|
||||
if fill < 0 || fill > 255 then raise (Eval_error "make-bytevector: fill must be 0-255");
|
||||
SxBytevector (Bytes.make n (Char.chr fill))
|
||||
| _ -> raise (Eval_error "make-bytevector: expected n [fill]"));
|
||||
register "bytevector?" (fun args ->
|
||||
match args with
|
||||
| [SxBytevector _] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "bytevector?: 1 arg"));
|
||||
register "bytevector-length" (fun args ->
|
||||
match args with
|
||||
| [SxBytevector b] -> Integer (Bytes.length b)
|
||||
| _ -> raise (Eval_error "bytevector-length: expected bytevector"));
|
||||
register "bytevector-u8-ref" (fun args ->
|
||||
match args with
|
||||
| [SxBytevector b; Integer i] ->
|
||||
if i < 0 || i >= Bytes.length b then
|
||||
raise (Eval_error (Printf.sprintf "bytevector-u8-ref: index %d out of range" i));
|
||||
Integer (Char.code (Bytes.get b i))
|
||||
| _ -> raise (Eval_error "bytevector-u8-ref: expected bytevector index"));
|
||||
register "bytevector-u8-set!" (fun args ->
|
||||
match args with
|
||||
| [SxBytevector b; Integer i; Integer byte] ->
|
||||
if i < 0 || i >= Bytes.length b then
|
||||
raise (Eval_error (Printf.sprintf "bytevector-u8-set!: index %d out of range" i));
|
||||
if byte < 0 || byte > 255 then
|
||||
raise (Eval_error "bytevector-u8-set!: byte must be 0-255");
|
||||
Bytes.set b i (Char.chr byte); Nil
|
||||
| _ -> raise (Eval_error "bytevector-u8-set!: expected bytevector index byte"));
|
||||
register "bytevector-copy" (fun args ->
|
||||
match args with
|
||||
| [SxBytevector b] -> SxBytevector (Bytes.copy b)
|
||||
| [SxBytevector b; Integer start] ->
|
||||
let len = Bytes.length b - start in
|
||||
SxBytevector (Bytes.sub b start len)
|
||||
| [SxBytevector b; Integer start; Integer stop] ->
|
||||
SxBytevector (Bytes.sub b start (stop - start))
|
||||
| _ -> raise (Eval_error "bytevector-copy: expected bytevector [start [end]]"));
|
||||
register "bytevector-copy!" (fun args ->
|
||||
let do_copy dst at src start stop =
|
||||
let len = stop - start in
|
||||
Bytes.blit src start dst at len; Nil
|
||||
in
|
||||
match args with
|
||||
| [SxBytevector dst; Integer at; SxBytevector src] ->
|
||||
do_copy dst at src 0 (Bytes.length src)
|
||||
| [SxBytevector dst; Integer at; SxBytevector src; Integer start] ->
|
||||
do_copy dst at src start (Bytes.length src)
|
||||
| [SxBytevector dst; Integer at; SxBytevector src; Integer start; Integer stop] ->
|
||||
do_copy dst at src start stop
|
||||
| _ -> raise (Eval_error "bytevector-copy!: expected dst at src [start [end]]"));
|
||||
register "bytevector-append" (fun args ->
|
||||
let bufs = List.map (function
|
||||
| SxBytevector b -> b
|
||||
| _ -> raise (Eval_error "bytevector-append: expected bytevectors")) args in
|
||||
let total = List.fold_left (fun acc b -> acc + Bytes.length b) 0 bufs in
|
||||
let result = Bytes.create total in
|
||||
let pos = ref 0 in
|
||||
List.iter (fun b ->
|
||||
let len = Bytes.length b in
|
||||
Bytes.blit b 0 result !pos len;
|
||||
pos := !pos + len) bufs;
|
||||
SxBytevector result);
|
||||
register "utf8->string" (fun args ->
|
||||
match args with
|
||||
| [SxBytevector b] -> String (Bytes.to_string b)
|
||||
| [SxBytevector b; Integer start] ->
|
||||
String (Bytes.sub_string b start (Bytes.length b - start))
|
||||
| [SxBytevector b; Integer start; Integer stop] ->
|
||||
String (Bytes.sub_string b start (stop - start))
|
||||
| _ -> raise (Eval_error "utf8->string: expected bytevector [start [end]]"));
|
||||
register "string->utf8" (fun args ->
|
||||
match args with
|
||||
| [String s] -> SxBytevector (Bytes.of_string s)
|
||||
| [String s; Integer start] ->
|
||||
let len = String.length s - start in
|
||||
SxBytevector (Bytes.of_string (String.sub s start len))
|
||||
| [String s; Integer start; Integer stop] ->
|
||||
SxBytevector (Bytes.of_string (String.sub s start (stop - start)))
|
||||
| _ -> raise (Eval_error "string->utf8: expected string [start [end]]"));
|
||||
register "bytevector->list" (fun args ->
|
||||
match args with
|
||||
| [SxBytevector b] ->
|
||||
let items = List.init (Bytes.length b) (fun i -> Integer (Char.code (Bytes.get b i))) in
|
||||
List items
|
||||
| _ -> raise (Eval_error "bytevector->list: expected bytevector"));
|
||||
register "list->bytevector" (fun args ->
|
||||
match args with
|
||||
| [List items] | [ListRef { contents = items }] ->
|
||||
let bytes_list = List.map (function
|
||||
| Integer n when n >= 0 && n <= 255 -> Char.chr n
|
||||
| Integer n -> raise (Eval_error (Printf.sprintf "list->bytevector: byte %d out of range" n))
|
||||
| v -> raise (Eval_error ("list->bytevector: expected integer, got " ^ Sx_types.type_of v))) items in
|
||||
let b = Bytes.create (List.length bytes_list) in
|
||||
List.iteri (fun i c -> Bytes.set b i c) bytes_list;
|
||||
SxBytevector b
|
||||
| [Nil] -> SxBytevector (Bytes.create 0)
|
||||
| _ -> raise (Eval_error "list->bytevector: expected list"))
|
||||
|
||||
@@ -81,6 +81,7 @@ and value =
|
||||
| Rational of int * int (** Exact rational: numerator, denominator (reduced, denom>0). *)
|
||||
| SxSet of (string, value) Hashtbl.t (** Mutable set keyed by inspect(value). *)
|
||||
| SxRegexp of string * string * Re.re (** Regexp: source, flags, compiled. *)
|
||||
| SxBytevector of bytes (** Mutable bytevector — R7RS bytevector type. *)
|
||||
|
||||
(** String input port: source string + mutable cursor position. *)
|
||||
and sx_port_kind =
|
||||
@@ -516,8 +517,9 @@ let type_of = function
|
||||
| Port { sp_kind = PortInput _; _ } -> "input-port"
|
||||
| Port { sp_kind = PortOutput _; _ } -> "output-port"
|
||||
| Rational _ -> "rational"
|
||||
| SxSet _ -> "set"
|
||||
| SxRegexp _ -> "regexp"
|
||||
| SxSet _ -> "set"
|
||||
| SxRegexp _ -> "regexp"
|
||||
| SxBytevector _ -> "bytevector"
|
||||
|
||||
let is_nil = function Nil -> true | _ -> false
|
||||
let is_lambda = function Lambda _ -> true | _ -> false
|
||||
@@ -882,3 +884,4 @@ let rec inspect = function
|
||||
| Rational (n, d) -> Printf.sprintf "%d/%d" n d
|
||||
| SxSet ht -> Printf.sprintf "<set:%d>" (Hashtbl.length ht)
|
||||
| SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags
|
||||
| SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i)))))
|
||||
|
||||
Reference in New Issue
Block a user