From 7b4e2a5587f9593959b6356d905d57a13c5016da Mon Sep 17 00:00:00 2001 From: Michael Greenberg Date: Thu, 14 Dec 2023 20:07:12 -0500 Subject: [PATCH] like lawrence before me, i have conquered the dunes --- .gitignore | 7 + dune | 36 +++++ dune-project | 3 + dune-workspace | 4 + ocaml/ast.ml | 12 +- ocaml/ast_atd.atd | 26 ++-- ocaml/dash.ml | 241 ++-------------------------------- ocaml/dash.mli | 6 +- ocaml/dune | 52 ++++++++ ocaml/function_description.ml | 36 +++++ ocaml/json_to_shell.ml | 1 + ocaml/shell_to_json.ml | 2 + ocaml/type_description.ml | 191 +++++++++++++++++++++++++++ src/type_description.ml | 184 ++++++++++++++++++++++++++ 14 files changed, 550 insertions(+), 251 deletions(-) create mode 100644 dune create mode 100644 dune-project create mode 100644 dune-workspace create mode 100644 ocaml/dune create mode 100644 ocaml/function_description.ml create mode 100644 ocaml/type_description.ml create mode 100644 src/type_description.ml diff --git a/.gitignore b/.gitignore index 742690a..18939bd 100644 --- a/.gitignore +++ b/.gitignore @@ -22,8 +22,15 @@ Makefile /stamp-h1 # generated by make +/src/builtins.h +/src/nodes.h +/src/syntax.h +/src/token.h /src/token_vars.h +# generated by dune +_build + # Apple debug symbol bundles *.dSYM/ diff --git a/dune b/dune new file mode 100644 index 0000000..7ca799c --- /dev/null +++ b/dune @@ -0,0 +1,36 @@ +(data_only_dirs src) + +(rule + (deps (source_tree src) configure.ac Makefile.am) + (targets libdash.a dlldash.so + builtins.h nodes.h syntax.h token.h token_vars.h + ) + (action + (bash + "\ + \n set -e\ + \n if [ \"$(uname -s)\" = \"Darwin\" ]; then glibtoolize; else libtoolize; fi\ + \n aclocal && autoheader && automake --add-missing && autoconf\ + \n ./configure --prefix=\"$(pwd)\"\ + \n %{make}\ + \n %{make} install\ + \n cp lib/libdash.a libdash.a\ + \n cp lib/dlldash.so dlldash.so\ + \n cp src/{builtins,nodes,syntax,token,token_vars}.h .\ + \n"))) + +(subdir src + (rule + (deps ../builtins.h ../nodes.h ../syntax.h ../token.h ../token_vars.h) + (targets builtins.h nodes.h syntax.h token.h token_vars.h) + (action + (progn + (copy ../builtins.h builtins.h) + (copy ../nodes.h nodes.h) + (copy ../syntax.h syntax.h) + (copy ../token.h token.h) + (copy ../token_vars.h token_vars.h))))) + +(library + (name dash) + (foreign_archives dash)) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..12634e1 --- /dev/null +++ b/dune-project @@ -0,0 +1,3 @@ +(lang dune 3.12) +(name libdash) +(using ctypes 0.3) \ No newline at end of file diff --git a/dune-workspace b/dune-workspace new file mode 100644 index 0000000..42ee224 --- /dev/null +++ b/dune-workspace @@ -0,0 +1,4 @@ +(lang dune 3.12) +(env + (dev + (flags (:standard -warn-error -27)))) \ No newline at end of file diff --git a/ocaml/ast.ml b/ocaml/ast.ml index 8127b51..9205e83 100644 --- a/ocaml/ast.ml +++ b/ocaml/ast.ml @@ -86,25 +86,20 @@ let string_of_var_type = function open Ctypes -open Foreign open Dash let rec last = function | [] -> None | [x] -> Some x - | x::xs -> last xs + | _::xs -> last xs let skip = Command (-1,[],[],[]) -let special_chars : char list = explode "|&;<>()$`\\\"'" - type quote_mode = QUnquoted | QQuoted | QHeredoc -let needs_escaping c = List.mem c special_chars - let rec of_node (n : node union ptr) : t = if nullptr n then skip @@ -225,7 +220,7 @@ and of_binary (n : node union ptr) = (of_node (getf n nbinary_ch1), of_node (getf n nbinary_ch2)) and to_arg (n : narg structure) : arg = - let a,s,bqlist,stack = parse_arg ~tilde_ok:true ~assign:false (explode (getf n narg_text)) (getf n narg_backquote) [] in + let a,s,bqlist,stack = parse_arg ~assign:false (explode (getf n narg_text)) (getf n narg_backquote) [] in (* we should have used up the string and have no backquotes left in our list *) assert (s = []); assert (nullptr bqlist); @@ -304,6 +299,7 @@ and parse_arg ?tilde_ok:(tilde_ok=false) ~assign:(assign:bool) (s : char list) ( then (* we're in arithmetic or double quotes, so tilde is ignored *) arg_char assign (C '~') s bqlist stack else + let _ = tilde_ok in (* unused? *) let uname,s' = parse_tilde [] s in arg_char assign (T uname) s' bqlist stack (* ordinary character *) @@ -325,7 +321,7 @@ and parse_tilde acc s = and arg_char assign c s bqlist stack = let tilde_ok = match c with - | C c -> assign && (match last s with + | C _ -> assign && (match last s with | Some ':' -> true | _ -> false) | _ -> false diff --git a/ocaml/ast_atd.atd b/ocaml/ast_atd.atd index 647a1de..989789b 100644 --- a/ocaml/ast_atd.atd +++ b/ocaml/ast_atd.atd @@ -1,8 +1,8 @@ -type char = int +type char = int -type linno = int +type linno = int -type t = [ +type t = [ Command of (linno * assign list * args * redirection list) (* assign, args, redir *) | Pipe of (bool * t list) (* background?, commands *) | Redir of (linno * t * redirection list) @@ -19,15 +19,15 @@ type t = [ | Defun of (linno * string * t) (* name, body *) ] -type assign = (string * arg) +type assign = (string * arg) -type redirection = [ +type redirection = [ File of (redir_type * int * arg) | Dup of (dup_type * int * arg) | Heredoc of (heredoc_type * int * arg) ] -type redir_type = [ +type redir_type = [ To | Clobber | From @@ -35,21 +35,21 @@ type redir_type = [ | Append ] -type dup_type = [ +type dup_type = [ ToFD | FromFD ] -type heredoc_type = [ +type heredoc_type = [ Here | XHere (* for when in a quote... not sure when this comes up *) ] -type args = arg list +type args = arg list -type arg = arg_char list +type arg = arg_char list -type arg_char = [ +type arg_char = [ C of char | E of char (* escape... necessary for expansion *) | T of string option (* tilde *) @@ -59,7 +59,7 @@ type arg_char = [ | B of t (* backquote *) ] -type var_type = [ +type var_type = [ Normal | Minus | Plus @@ -72,7 +72,7 @@ type var_type = [ | Length ] -type case = { +type case = { cpattern : arg list; cbody : t } \ No newline at end of file diff --git a/ocaml/dash.ml b/ocaml/dash.ml index ec0f33f..65215e9 100644 --- a/ocaml/dash.ml +++ b/ocaml/dash.ml @@ -1,246 +1,33 @@ -open Printf open Ctypes -open Ctypes_types -open Foreign +include Cdash.Functions +include Cdash.Types (* First, some dash trivia. *) - -type stackmark - -let stackmark : stackmark structure typ = structure "stackmark" -let stackp = field stackmark "stackp" (ptr void) -let nxt = field stackmark "nxt" string -let size = field stackmark "stacknleft" PosixTypes.size_t -let () = seal stackmark -let init_stack () = - let stack = make stackmark in - foreign "setstackmark" (ptr stackmark @-> returning void) (addr stack); - stack - -let pop_stack stack = - foreign "popstackmark" (ptr stackmark @-> returning void) (addr stack) +type stackmark_t = Stackmark.stackmark -let alloc_stack_string = - foreign "sstrdup" (string @-> returning (ptr char)) - -let free_stack_string s = - foreign "stunalloc" (ptr char @-> returning void) s - -let dash_init : unit -> unit = foreign "init" (void @-> returning void) -let initialize_dash_errno : unit -> unit = - foreign "initialize_dash_errno" (void @-> returning void) +let init_stack () : stackmark = + let stack = Ctypes.make stackmark in + setstackmark (addr stack); + stack -let initialize () = +let pop_stack stack : unit = + popstackmark (addr stack) + +let initialize () : unit = initialize_dash_errno (); dash_init () -let popfile : unit -> unit = - foreign "popfile" (void @-> returning void) - -let setinputstring : char ptr -> unit = - foreign "setinputstring" (ptr char @-> returning void) - let setinputtostdin () : unit = - foreign "setinputfd" (int @-> int @-> returning void) 0 0 (* don't both pushing the file *) + setinputfd 0 0 (* don't bother pushing the file *) let setinputfile ?push:(push=false) (s : string) : unit = - let _ = foreign "setinputfile" (string @-> int @-> returning int) s (if push then 1 else 0) in + let _ = raw_setinputfile s (if push then 1 else 0) in () let setvar (x : string) (v : string) : unit = - let _ = foreign "setvar" (string @-> string @-> int @-> returning (ptr void)) x v 0 in + let _ = raw_setvar x v 0 in () - -let setalias (name : string) (mapping : string) : unit = - foreign "setalias" (string @-> string @-> returning void) name mapping - -let unalias (name : string) : unit = - foreign "unalias" (string @-> returning void) name - -(* Next, a utility function that isn't in Unix or ExtUnix. *) - -let freshfd_ge10 (fd : int) : int = - foreign "freshfd_ge10" (int @-> returning int) fd - -(* Actual AST stuff begins here. *) -(* first, we define the node type... *) - -type node -let node : node union typ = union "node" -let node_type = field node "type" int -(* but we don't seal it yet! *) - -type nodelist -let nodelist : nodelist structure typ = structure "nodelist" -let nodelist_next = field nodelist "next" (ptr nodelist) -let nodelist_n = field nodelist "n" (ptr node) -let () = seal nodelist - -type ncmd - -let ncmd : ncmd structure typ = structure "ncmd" -let ncmd_type = field ncmd "type" int -let ncmd_linno = field ncmd "linno" int -let ncmd_assign = field ncmd "assign" (ptr node) -let ncmd_args = field ncmd "args" (ptr node) -let ncmd_redirect = field ncmd "redirect" (ptr node) -let () = seal ncmd - -let node_ncmd = field node "ncmd" ncmd - -type npipe - -let npipe : npipe structure typ = structure "npipe" -let npipe_type = field npipe "type" int -let npipe_backgnd = field npipe "backgnd" int -let npipe_cmdlist = field npipe "cmdlist" (ptr nodelist) -let () = seal npipe - -let node_npipe = field node "npipe" npipe - -type nredir - -let nredir : nredir structure typ = structure "nredir" -let nredir_type = field nredir "type" int -let nredir_linno = field nredir "linno" int -let nredir_n = field nredir "n" (ptr node) -let nredir_redirect = field nredir "redirect" (ptr node) -let () = seal nredir - -let node_nredir = field node "nredir" nredir - -type nbinary - -let nbinary : nbinary structure typ = structure "nbinary" -let nbinary_type = field nbinary "type" int -let nbinary_ch1 = field nbinary "ch1" (ptr node) -let nbinary_ch2 = field nbinary "ch2" (ptr node) -let () = seal nbinary - -let node_nbinary = field node "nbinary" nbinary - -type nif - -let nif : nif structure typ = structure "nif" -let nif_type = field nif "type" int -let nif_test = field nif "test" (ptr node) -let nif_ifpart = field nif "ifpart" (ptr node) -let nif_elsepart = field nif "elsepart" (ptr node) -let () = seal nif - -let node_nif = field node "nif" nif - -type nfor - -let nfor : nfor structure typ = structure "nfor" -let nfor_type = field nfor "type" int -let nfor_linno = field nfor "linno" int -let nfor_args = field nfor "args" (ptr node) -let nfor_body = field nfor "body" (ptr node) -let nfor_var = field nfor "var" string -let () = seal nfor - -let node_nfor = field node "nfor" nfor - -type ncase - -let ncase : ncase structure typ = structure "ncase" -let ncase_type = field ncase "type" int -let ncase_linno = field ncase "linno" int -let ncase_expr = field ncase "expr" (ptr node) -let ncase_cases = field ncase "cases" (ptr node) -let () = seal ncase - -let node_ncase = field node "ncase" ncase - -type nclist - -let nclist : nclist structure typ = structure "nclist" -let nclist_type = field nclist "type" int -let nclist_next = field nclist "next" (ptr node) -let nclist_pattern = field nclist "pattern" (ptr node) -let nclist_body = field nclist "body" (ptr node) -let () = seal nclist - -let node_nclist = field node "nclist" nclist - -type ndefun - -let ndefun : ndefun structure typ = structure "ndefun" -let ndefun_type = field ndefun "type" int -let ndefun_linno = field ndefun "linno" int -let ndefun_text = field ndefun "text" string -let ndefun_body = field ndefun "body" (ptr node) -let () = seal ndefun - -let node_ndefun = field node "ndefun" ndefun - -type narg - -let narg : narg structure typ = structure "narg" -let narg_type = field narg "type" int -let narg_next = field narg "next" (ptr node) -let narg_text = field narg "text" string -let narg_backquote = field narg "backquote" (ptr nodelist) -let () = seal narg - -let node_narg = field node "narg" narg - -type nfile - -let nfile : nfile structure typ = structure "nfile" -let nfile_type = field nfile "type" int -let nfile_next = field nfile "next" (ptr node) -let nfile_fd = field nfile "fd" int -let nfile_fname = field nfile "fname" (ptr node) -let nfile_expfname = field nfile "expfname" string -let () = seal nfile - -let node_nfile = field node "nfile" nfile - -type ndup - -let ndup : ndup structure typ = structure "ndup" -let ndup_type = field ndup "type" int -let ndup_next = field ndup "next" (ptr node) -let ndup_fd = field ndup "fd" int -let ndup_dupfd = field ndup "dupfd" int -let ndup_vname = field ndup "vname" (ptr node) -let () = seal ndup - -let node_ndup = field node "ndup" ndup - -type nhere - -let nhere : nhere structure typ = structure "nhere" -let nhere_type = field nhere "type" int -let nhere_next = field nhere "next" (ptr node) -let nhere_fd = field nhere "fd" int -let nhere_doc = field nhere "doc" (ptr node) -let () = seal nhere - -let node_nhere = field node "nhere" nhere - -type nnot - -let nnot : nnot structure typ = structure "nnot" -let nnot_type = field nnot "type" int -let nnot_com = field nnot "com" (ptr node) -let () = seal nnot - -let node_nnot = field node "nnot" nnot -let () = seal node - -let parsecmd_safe : int -> node union ptr = - foreign "parsecmd_safe" (int @-> returning (ptr node)) - -let parse s = - setinputstring s; (* TODO set stack mark? *) - parsecmd_safe 0 - -let neof : node union ptr = foreign_value "tokpushback" node -let nerr : node union ptr = foreign_value "lasttoken" node let addrof p = raw_address_of_ptr (to_voidp p) diff --git a/ocaml/dash.mli b/ocaml/dash.mli index f18c119..a7bf212 100644 --- a/ocaml/dash.mli +++ b/ocaml/dash.mli @@ -11,9 +11,9 @@ val initialize : unit -> unit see libdash/test/test.ml for an example usage in parse_all *) -type stackmark -val init_stack : unit -> stackmark Ctypes.structure -val pop_stack : stackmark Ctypes.structure -> unit +type stackmark_t +val init_stack : unit -> stackmark_t Ctypes.structure +val pop_stack : stackmark_t Ctypes.structure -> unit val alloc_stack_string : string -> (char Ctypes.ptr) val free_stack_string : (char Ctypes.ptr) -> unit diff --git a/ocaml/dune b/ocaml/dune new file mode 100644 index 0000000..b0ebca6 --- /dev/null +++ b/ocaml/dune @@ -0,0 +1,52 @@ +(executables + (names shell_to_json json_to_shell) + (public_names shell_to_json json_to_shell) + (modules shell_to_json json_to_shell ast_json) + (modes (native exe)) + (libraries libdash yojson atdgen)) + +(library + (name libdash) + (public_name libdash) + (modes native) + (modules (:standard \ json_to_shell shell_to_json ast_json)) + (libraries ctypes ctypes.foreign) +; (library_flags (-linkall)) + (foreign_archives ../dash) + (ctypes + (external_library_name dash) + (build_flags_resolver (vendored (c_flags :standard) (c_library_flags :standard))) + (deps (glob_files ../src/*.h) ../src/builtins.h ../src/nodes.h ../src/syntax.h ../src/token.h ../src/token_vars.h) + (headers (preamble + "\ + \n#include \"../src/shell.h\"\ + \n#include \"../src/memalloc.h\"\ + \n#include \"../src/mystring.h\"\ + \n#include \"../src/init.h\"\ + \n#include \"../src/main.h\"\ + \n#include \"../src/input.h\"\ + \n#include \"../src/var.h\"\ + \n#include \"../src/alias.h\"\ + \n#include \"../src/redir.h\"\ + \n#include \"../src/parser.h\"\ + \n#include \"../src/nodes.h\"\ + \n")) + (type_description + (instance Types) + (functor Type_description)) + (function_description + (instance Functions) + (functor Function_description)) + (generated_types Types_generated) + (generated_entry_point Cdash))) + +(rule + (targets ast_json.mli ast_json.ml) + (deps ast_atd.atd) + (action + (progn + (run atdgen -j -j-std ast_atd.atd) + (run sed -i -e "/type char = Libdash.Ast.char/d" ast_atd_j.ml) + (run sed -i -e "/type char = Libdash.Ast.char/d" ast_atd_j.mli) + (run mv ast_atd_j.ml ast_json.ml) + (run mv ast_atd_j.mli ast_json.mli)))) diff --git a/ocaml/function_description.ml b/ocaml/function_description.ml new file mode 100644 index 0000000..cf65d95 --- /dev/null +++ b/ocaml/function_description.ml @@ -0,0 +1,36 @@ +open Ctypes + +module Types = Types_generated +open Types + +module Functions (F : Ctypes.FOREIGN) = struct + open F + + let setstackmark = foreign "setstackmark" (ptr stackmark @-> returning void) + let popstackmark = foreign "popstackmark" (ptr stackmark @-> returning void) + + let alloc_stack_string = foreign "sstrdup" (string @-> returning (ptr char)) + let free_stack_string = foreign "stunalloc" (ptr char @-> returning void) + + let dash_init = foreign "init" (void @-> returning void) + let initialize_dash_errno = foreign "initialize_dash_errno" (void @-> returning void) + + let popfile = foreign "popfile" (void @-> returning void) + let setinputstring = foreign "setinputstring" (ptr char @-> returning void) + let setinputfd = foreign "setinputfd" (int @-> int @-> returning void) + let raw_setinputfile = foreign "setinputfile" (string @-> int @-> returning int) + + let raw_setvar = foreign "setvar" (string @-> string @-> int @-> returning (ptr void)) + + let setalias = foreign "setalias" (string @-> string @-> returning void) + let unalias = foreign "unalias" (string @-> returning void) + + (* Unix/ExtUnix don't let you renumber things the way you want *) + let freshfd_ge10 = foreign "freshfd_ge10" (int @-> returning int) + + let parsecmd_safe = foreign "parsecmd_safe" (int @-> returning (ptr node)) + let neof = foreign_value "tokpushback" node + let nerr = foreign_value "lasttoken" node +end + + diff --git a/ocaml/json_to_shell.ml b/ocaml/json_to_shell.ml index 7f41033..2474e8c 100644 --- a/ocaml/json_to_shell.ml +++ b/ocaml/json_to_shell.ml @@ -1,4 +1,5 @@ (* This is straight-up copied from the libdash tests *) +open Libdash let verbose = ref false let input_src : string option ref = ref None diff --git a/ocaml/shell_to_json.ml b/ocaml/shell_to_json.ml index d170e5c..29f32ac 100644 --- a/ocaml/shell_to_json.ml +++ b/ocaml/shell_to_json.ml @@ -1,5 +1,7 @@ (* This is straight-up copied from the libdash tests *) +open Libdash + let verbose = ref false let input_src : string option ref = ref None diff --git a/ocaml/type_description.ml b/ocaml/type_description.ml new file mode 100644 index 0000000..ef6a134 --- /dev/null +++ b/ocaml/type_description.ml @@ -0,0 +1,191 @@ +open Ctypes + +module Types (F : Ctypes.TYPE) = struct + open F + + (* stackmarks [used for string allocation in dash] *) + module Stackmark = struct + + type stackmark + type t = stackmark Ctypes.structure + + let t : stackmark structure typ = structure "stackmark" + let stackp = field t "stackp" (ptr void) + let nxt = field t "stacknxt" string + let size = field t "stacknleft" F.size_t + let () = seal t + end + + type stackmark = Stackmark.t + let stackmark = Stackmark.t + + (* AST nodes *) + + (* define the node type... *) + type node + let node : node union typ = union "node" + let node_type = field node "type" int + (* ...but don't seal it yet! *) + + type nodelist + let nodelist : nodelist structure typ = structure "nodelist" + let nodelist_next = field nodelist "next" (ptr nodelist) + let nodelist_n = field nodelist "n" (ptr node) + let () = seal nodelist + + type ncmd + + let ncmd : ncmd structure typ = structure "ncmd" + let ncmd_type = field ncmd "type" int + let ncmd_linno = field ncmd "linno" int + let ncmd_assign = field ncmd "assign" (ptr node) + let ncmd_args = field ncmd "args" (ptr node) + let ncmd_redirect = field ncmd "redirect" (ptr node) + let () = seal ncmd + + let node_ncmd = field node "ncmd" ncmd + + type npipe + + let npipe : npipe structure typ = structure "npipe" + let npipe_type = field npipe "type" int + let npipe_backgnd = field npipe "backgnd" int + let npipe_cmdlist = field npipe "cmdlist" (ptr nodelist) + let () = seal npipe + + let node_npipe = field node "npipe" npipe + + type nredir + + let nredir : nredir structure typ = structure "nredir" + let nredir_type = field nredir "type" int + let nredir_linno = field nredir "linno" int + let nredir_n = field nredir "n" (ptr node) + let nredir_redirect = field nredir "redirect" (ptr node) + let () = seal nredir + + let node_nredir = field node "nredir" nredir + + type nbinary + + let nbinary : nbinary structure typ = structure "nbinary" + let nbinary_type = field nbinary "type" int + let nbinary_ch1 = field nbinary "ch1" (ptr node) + let nbinary_ch2 = field nbinary "ch2" (ptr node) + let () = seal nbinary + + let node_nbinary = field node "nbinary" nbinary + + type nif + + let nif : nif structure typ = structure "nif" + let nif_type = field nif "type" int + let nif_test = field nif "test" (ptr node) + let nif_ifpart = field nif "ifpart" (ptr node) + let nif_elsepart = field nif "elsepart" (ptr node) + let () = seal nif + + let node_nif = field node "nif" nif + + type nfor + + let nfor : nfor structure typ = structure "nfor" + let nfor_type = field nfor "type" int + let nfor_linno = field nfor "linno" int + let nfor_args = field nfor "args" (ptr node) + let nfor_body = field nfor "body" (ptr node) + let nfor_var = field nfor "var" string + let () = seal nfor + + let node_nfor = field node "nfor" nfor + + type ncase + + let ncase : ncase structure typ = structure "ncase" + let ncase_type = field ncase "type" int + let ncase_linno = field ncase "linno" int + let ncase_expr = field ncase "expr" (ptr node) + let ncase_cases = field ncase "cases" (ptr node) + let () = seal ncase + + let node_ncase = field node "ncase" ncase + + type nclist + + let nclist : nclist structure typ = structure "nclist" + let nclist_type = field nclist "type" int + let nclist_next = field nclist "next" (ptr node) + let nclist_pattern = field nclist "pattern" (ptr node) + let nclist_body = field nclist "body" (ptr node) + let () = seal nclist + + let node_nclist = field node "nclist" nclist + + type ndefun + + let ndefun : ndefun structure typ = structure "ndefun" + let ndefun_type = field ndefun "type" int + let ndefun_linno = field ndefun "linno" int + let ndefun_text = field ndefun "text" string + let ndefun_body = field ndefun "body" (ptr node) + let () = seal ndefun + + let node_ndefun = field node "ndefun" ndefun + + type narg + + let narg : narg structure typ = structure "narg" + let narg_type = field narg "type" int + let narg_next = field narg "next" (ptr node) + let narg_text = field narg "text" string + let narg_backquote = field narg "backquote" (ptr nodelist) + let () = seal narg + + let node_narg = field node "narg" narg + + type nfile + + let nfile : nfile structure typ = structure "nfile" + let nfile_type = field nfile "type" int + let nfile_next = field nfile "next" (ptr node) + let nfile_fd = field nfile "fd" int + let nfile_fname = field nfile "fname" (ptr node) + let nfile_expfname = field nfile "expfname" string + let () = seal nfile + + let node_nfile = field node "nfile" nfile + + type ndup + + let ndup : ndup structure typ = structure "ndup" + let ndup_type = field ndup "type" int + let ndup_next = field ndup "next" (ptr node) + let ndup_fd = field ndup "fd" int + let ndup_dupfd = field ndup "dupfd" int + let ndup_vname = field ndup "vname" (ptr node) + let () = seal ndup + + let node_ndup = field node "ndup" ndup + + type nhere + + let nhere : nhere structure typ = structure "nhere" + let nhere_type = field nhere "type" int + let nhere_next = field nhere "next" (ptr node) + let nhere_fd = field nhere "fd" int + let nhere_doc = field nhere "doc" (ptr node) + let () = seal nhere + + let node_nhere = field node "nhere" nhere + + type nnot + + let nnot : nnot structure typ = structure "nnot" + let nnot_type = field nnot "type" int + let nnot_com = field nnot "com" (ptr node) + let () = seal nnot + + let node_nnot = field node "nnot" nnot + let () = seal node + +end diff --git a/src/type_description.ml b/src/type_description.ml new file mode 100644 index 0000000..7ee7915 --- /dev/null +++ b/src/type_description.ml @@ -0,0 +1,184 @@ +open Ctypes + +module Types (F : Ctypes.TYPE) = struct + open F + + (* stackmarks [used for string allocation in dash] *) + type stackmark + + let stackmark : stackmark structure typ = structure "stackmark" + let stackp = field stackmark "stackp" (ptr void) + let nxt = field stackmark "nxt" string + let size = field stackmark "stacknleft" F.size_t + let () = seal stackmark + + (* AST nodes *) + + (* define the node type... *) + type node + let node : node union typ = union "node" + let node_type = field node "type" int + (* ...but don't seal it yet! *) + + type nodelist + let nodelist : nodelist structure typ = structure "nodelist" + let nodelist_next = field nodelist "next" (ptr nodelist) + let nodelist_n = field nodelist "n" (ptr node) + let () = seal nodelist + + type ncmd + + let ncmd : ncmd structure typ = structure "ncmd" + let ncmd_type = field ncmd "type" int + let ncmd_linno = field ncmd "linno" int + let ncmd_assign = field ncmd "assign" (ptr node) + let ncmd_args = field ncmd "args" (ptr node) + let ncmd_redirect = field ncmd "redirect" (ptr node) + let () = seal ncmd + + let node_ncmd = field node "ncmd" ncmd + + type npipe + + let npipe : npipe structure typ = structure "npipe" + let npipe_type = field npipe "type" int + let npipe_backgnd = field npipe "backgnd" int + let npipe_cmdlist = field npipe "cmdlist" (ptr nodelist) + let () = seal npipe + + let node_npipe = field node "npipe" npipe + + type nredir + + let nredir : nredir structure typ = structure "nredir" + let nredir_type = field nredir "type" int + let nredir_linno = field nredir "linno" int + let nredir_n = field nredir "n" (ptr node) + let nredir_redirect = field nredir "redirect" (ptr node) + let () = seal nredir + + let node_nredir = field node "nredir" nredir + + type nbinary + + let nbinary : nbinary structure typ = structure "nbinary" + let nbinary_type = field nbinary "type" int + let nbinary_ch1 = field nbinary "ch1" (ptr node) + let nbinary_ch2 = field nbinary "ch2" (ptr node) + let () = seal nbinary + + let node_nbinary = field node "nbinary" nbinary + + type nif + + let nif : nif structure typ = structure "nif" + let nif_type = field nif "type" int + let nif_test = field nif "test" (ptr node) + let nif_ifpart = field nif "ifpart" (ptr node) + let nif_elsepart = field nif "elsepart" (ptr node) + let () = seal nif + + let node_nif = field node "nif" nif + + type nfor + + let nfor : nfor structure typ = structure "nfor" + let nfor_type = field nfor "type" int + let nfor_linno = field nfor "linno" int + let nfor_args = field nfor "args" (ptr node) + let nfor_body = field nfor "body" (ptr node) + let nfor_var = field nfor "var" string + let () = seal nfor + + let node_nfor = field node "nfor" nfor + + type ncase + + let ncase : ncase structure typ = structure "ncase" + let ncase_type = field ncase "type" int + let ncase_linno = field ncase "linno" int + let ncase_expr = field ncase "expr" (ptr node) + let ncase_cases = field ncase "cases" (ptr node) + let () = seal ncase + + let node_ncase = field node "ncase" ncase + + type nclist + + let nclist : nclist structure typ = structure "nclist" + let nclist_type = field nclist "type" int + let nclist_next = field nclist "next" (ptr node) + let nclist_pattern = field nclist "pattern" (ptr node) + let nclist_body = field nclist "body" (ptr node) + let () = seal nclist + + let node_nclist = field node "nclist" nclist + + type ndefun + + let ndefun : ndefun structure typ = structure "ndefun" + let ndefun_type = field ndefun "type" int + let ndefun_linno = field ndefun "linno" int + let ndefun_text = field ndefun "text" string + let ndefun_body = field ndefun "body" (ptr node) + let () = seal ndefun + + let node_ndefun = field node "ndefun" ndefun + + type narg + + let narg : narg structure typ = structure "narg" + let narg_type = field narg "type" int + let narg_next = field narg "next" (ptr node) + let narg_text = field narg "text" string + let narg_backquote = field narg "backquote" (ptr nodelist) + let () = seal narg + + let node_narg = field node "narg" narg + + type nfile + + let nfile : nfile structure typ = structure "nfile" + let nfile_type = field nfile "type" int + let nfile_next = field nfile "next" (ptr node) + let nfile_fd = field nfile "fd" int + let nfile_fname = field nfile "fname" (ptr node) + let nfile_expfname = field nfile "expfname" string + let () = seal nfile + + let node_nfile = field node "nfile" nfile + + type ndup + + let ndup : ndup structure typ = structure "ndup" + let ndup_type = field ndup "type" int + let ndup_next = field ndup "next" (ptr node) + let ndup_fd = field ndup "fd" int + let ndup_dupfd = field ndup "dupfd" int + let ndup_vname = field ndup "vname" (ptr node) + let () = seal ndup + + let node_ndup = field node "ndup" ndup + + type nhere + + let nhere : nhere structure typ = structure "nhere" + let nhere_type = field nhere "type" int + let nhere_next = field nhere "next" (ptr node) + let nhere_fd = field nhere "fd" int + let nhere_doc = field nhere "doc" (ptr node) + let () = seal nhere + + let node_nhere = field node "nhere" nhere + + type nnot + + let nnot : nnot structure typ = structure "nnot" + let nnot_type = field nnot "type" int + let nnot_com = field nnot "com" (ptr node) + let () = seal nnot + + let node_nnot = field node "nnot" nnot + let () = seal node + +end