[r2004-12-31 00:28:02 by afrisch] Empty log message

Original author: afrisch
Date: 2004-12-31 00:28:02+00:00

Makefile.distrib

@@ -176,7 +176,8 @@ OBJECTS = \
  \
  types/builtin.cmo \
  driver/librarian.cmo \
- driver/cduce.cmo
+ driver/cduce.cmo \
+ runtime/system.cmo
 
 schema/schema_types.ml: schema/schema_types.mli
 	cp $^ $@

runtime/system.ml

+open Operators
+open Builtin_defs
+
+let len = 1024;;
+
+register_fun "system"
+  string_latin1 string_latin1
+  (fun v ->
+     Location.protect_op "system";
+     let s = Value.get_string_latin1 v in
+     let ic = Unix.open_process_in s in
+     let b = Buffer.create (1024*10) in
+     let buf = String.create len in
+     let rec aux () =
+       let i = input ic buf 0 len in
+       if i = 0 then () else (Buffer.add_string b (String.sub buf 0 i); aux ())
+     in
+     aux ();
+     let s = Value.string_latin1 (Buffer.contents b) in
+     match Unix.close_process_in ic with
+       | Unix.WEXITED n ->
+	   if (n = 0) then s
+	   else
+	     Value.raise' 
+	       (Value.tagged_tuple "exited" [ Value.ocaml2cduce_int n; s ])
+       | Unix.WSTOPPED n ->
+	   Value.raise' 
+	     (Value.tagged_tuple "stopped" [ Value.ocaml2cduce_int n; s ])
+       | Unix.WSIGNALED n ->
+	   Value.raise' 
+	     (Value.tagged_tuple "signaled" [ Value.ocaml2cduce_int n; s ])
+  )

runtime/value.ml

@@ -495,6 +495,13 @@ let map_xml map_pcdata map_other =
     | Xml (tag,attrs,cont) -> Xml (tag, attrs, aux cont)
     | _ -> raise (Invalid_argument "Value.map_xml")
 
+
+let tagged_tuple tag vl =
+  let ct = sequence vl in
+  let at = Record LabelMap.empty in
+  let tag = Atom (Atoms.V.mk_ascii tag) in
+  Xml (tag, at, ct)
+
   (** set of values *)
 
 type tmp = t

runtime/value.mli

@@ -26,6 +26,7 @@ module ValueSet: Set.S with type elt = t
 exception CDuceExn of t
 val raise': t -> 'a           (* "raise" for CDuce exceptions *)
 val failwith': string -> 'a   (* "failwith" for CDuce exceptions *)
+val tagged_tuple: string -> t list -> t
 
 val print: Format.formatter -> t -> unit
 val dump_xml: Format.formatter -> t -> unit

types/builtin.ml

@@ -188,6 +188,7 @@ register_fun "print_xml_utf8"
   Types.any string
   (fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);;
 
+
 register_fun "print"
   string_latin1 nil
   (fun v ->