pga/parse.ml

open Types

type token = LPAREN | RPAREN | ID of string | HASH | EXCLAM | PLUS | MINUS

let is_alnum c =
  let i = int_of_char c in
  i >= 48 & i <= 57 || i >= 65 & i <= 90 || i >= 97 & i <= 122

let tokenize next_char emit =
  let buf = Buffer.create 32 in
  let lineno = ref 1 in
  let colno = ref 1 in

  let unexpected c =
    ParseError (Printf.sprintf
      "unexpected '%c' at line %d, character %d"
      c !lineno !colno
    )
  in

  let emit_buf () =
    if Buffer.length buf = 0 then
      ()
    else
      emit (ID (Buffer.contents buf));
      Buffer.clear buf
  in
  let nobuf c =
    if Buffer.length buf > 0 then raise (unexpected c)
  in

  let rec read_all () =
    match next_char () with
    | Some c ->
      begin
        match c with
        | '(' -> nobuf c; emit LPAREN
        | ')' -> emit_buf (); emit RPAREN
        | ';' -> emit_buf ()
        | '#' -> nobuf c; emit HASH
        | '!' -> nobuf c; emit EXCLAM
        | '+' -> nobuf c; emit PLUS
        | '-' -> nobuf c; emit MINUS
        | ' ' | '\t' | '\r' -> emit_buf ()
        | '\n' -> emit_buf (); incr lineno; colno := 0
        | c when is_alnum c -> Buffer.add_char buf c
        | _ -> raise (unexpected c)
      end;
      incr colno;
      read_all ()
    | None ->
      emit_buf ()
  in
  read_all ()

let program_of_list = function
  | []  -> Empty
  | [p] -> p
  | p   -> Concat p

type exp = E_basic | E_jump  | E_ptest | E_ntest

let parse next_char =
  let stack = ref [ref []] in
  let expect = ref E_basic in
  let append p =
    let lst = List.hd !stack in
    lst := p :: !lst
  in
  let handler = function
    | EXCLAM -> append (Primitive Terminate)
    | HASH   -> expect := E_jump
    | PLUS   -> expect := E_ptest
    | MINUS  -> expect := E_ntest
    | LPAREN -> stack := ref [] :: !stack
    | RPAREN ->
      if List.length !stack < 2 then begin
        raise (ParseError "too many closing parentheses")
      end;
      let body = List.rev !(List.hd !stack) in
      stack := List.tl !stack;
      append (Repeat (program_of_list body))
    | ID s ->
      let p =
        match !expect with
        | E_basic -> Basic s
        | E_jump  -> Jump (int_of_string s)
        | E_ptest -> Ptest s
        | E_ntest -> Ntest s
      in
      append (Primitive p);
      expect := E_basic
  in
  tokenize next_char handler;

  if List.length !stack > 1 then
    raise (ParseError "missing closing parenthesis");

  Concat (List.rev !(List.hd !stack))

let parse_string s =
  let i = ref 0 in
  let next_char () =
    if !i = String.length s
      then None
      else (incr i; Some (String.get s (!i - 1)))
  in
  parse next_char