Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
ocaml/runtime/parsing.c

305 lines
9.1 KiB
C
Raw Permalink Blame History

/**************************************************************************/
/* */
/* OCaml */
/* */
/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. */
/* */
/* All rights reserved. This file is distributed under the terms of */
/* the GNU Lesser General Public License version 2.1, with the */
/* special exception on linking described in the file LICENSE. */
/* */
/**************************************************************************/
#define CAML_INTERNALS
/* The PDA automaton for parsers generated by camlyacc */
#include <stdio.h>
#include <string.h>
#include "caml/config.h"
#include "caml/mlvalues.h"
#include "caml/memory.h"
#include "caml/alloc.h"
#define ERRCODE 256
struct parser_tables { /* Mirrors parse_tables in ../stdlib/parsing.mli */
value actions;
value transl_const;
value transl_block;
char * lhs;
char * len;
char * defred;
char * dgoto;
char * sindex;
char * rindex;
char * gindex;
value tablesize;
char * table;
char * check;
value error_function;
char * names_const;
char * names_block;
};
struct parser_env { /* Mirrors parser_env in ../stdlib/parsing.ml */
value s_stack;
value v_stack;
value symb_start_stack;
value symb_end_stack;
value stacksize;
value stackbase;
value curr_char;
value lval;
value symb_start;
value symb_end;
value asp;
value rule_len;
value rule_number;
value sp;
value state;
value errflag;
};
#if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2
#define Short(tbl,n) \
(*((unsigned char *)((tbl) + (n) * 2)) + \
(*((signed char *)((tbl) + (n) * 2 + 1)) << 8))
#else
#define Short(tbl,n) (((short *)(tbl))[n])
#endif
int caml_parser_trace = 0;
/* Input codes */
/* Mirrors parser_input in ../stdlib/parsing.ml */
#define START 0
#define TOKEN_READ 1
#define STACKS_GROWN_1 2
#define STACKS_GROWN_2 3
#define SEMANTIC_ACTION_COMPUTED 4
#define ERROR_DETECTED 5
/* Output codes */
/* Mirrors parser_output in ../stdlib/parsing.ml */
#define READ_TOKEN Val_int(0)
#define RAISE_PARSE_ERROR Val_int(1)
#define GROW_STACKS_1 Val_int(2)
#define GROW_STACKS_2 Val_int(3)
#define COMPUTE_SEMANTIC_ACTION Val_int(4)
#define CALL_ERROR_FUNCTION Val_int(5)
/* To preserve local variables when communicating with the ML code */
#define SAVE \
env->sp = Val_int(sp), \
env->state = Val_int(state), \
env->errflag = Val_int(errflag)
#define RESTORE \
sp = Int_val(env->sp), \
state = Int_val(env->state), \
errflag = Int_val(env->errflag)
/* Auxiliary for printing token just read */
static char * token_name(char * names, int number)
{
for (/*nothing*/; number > 0; number--) {
if (names[0] == 0) return "<unknown token>";
names += strlen(names) + 1;
}
return names;
}
static void print_token(struct parser_tables *tables, int state, value tok)
{
value v;
if (Is_long(tok)) {
fprintf(stderr, "State %d: read token %s\n",
state, token_name(tables->names_const, Int_val(tok)));
} else {
fprintf(stderr, "State %d: read token %s(",
state, token_name(tables->names_block, Tag_val(tok)));
v = Field(tok, 0);
if (Is_long(v))
fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
else if (Tag_val(v) == String_tag)
fprintf(stderr, "%s", String_val(v));
else if (Tag_val(v) == Double_tag)
fprintf(stderr, "%g", Double_val(v));
else
fprintf(stderr, "_");
fprintf(stderr, ")\n");
}
}
/* The pushdown automata */
CAMLprim value caml_parse_engine(struct parser_tables *tables,
struct parser_env *env, value cmd, value arg)
{
int state;
mlsize_t sp, asp;
int errflag;
int n, n1, n2, m, state1;
switch(Int_val(cmd)) {
case START:
state = 0;
sp = Int_val(env->sp);
errflag = 0;
loop:
n = Short(tables->defred, state);
if (n != 0) goto reduce;
if (Int_val(env->curr_char) >= 0) goto testshift;
SAVE;
return READ_TOKEN;
/* The ML code calls the lexer and updates */
/* symb_start and symb_end */
case TOKEN_READ:
RESTORE;
if (Is_block(arg)) {
env->curr_char = Field(tables->transl_block, Tag_val(arg));
caml_modify(&env->lval, Field(arg, 0));
} else {
env->curr_char = Field(tables->transl_const, Int_val(arg));
caml_modify(&env->lval, Val_long(0));
}
if (caml_parser_trace) print_token(tables, state, arg);
testshift:
n1 = Short(tables->sindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) goto shift;
n1 = Short(tables->rindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) {
n = Short(tables->table, n2);
goto reduce;
}
if (errflag > 0) goto recover;
SAVE;
return CALL_ERROR_FUNCTION;
/* The ML code calls the error function */
case ERROR_DETECTED:
RESTORE;
recover:
if (errflag < 3) {
errflag = 3;
while (1) {
state1 = Int_val(Field(env->s_stack, sp));
n1 = Short(tables->sindex, state1);
n2 = n1 + ERRCODE;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == ERRCODE) {
if (caml_parser_trace)
fprintf(stderr, "Recovering in state %d\n", state1);
goto shift_recover;
} else {
if (caml_parser_trace){
fprintf(stderr, "Discarding state %d\n", state1);
}
if (sp <= Int_val(env->stackbase)) {
if (caml_parser_trace){
fprintf(stderr, "No more states to discard\n");
}
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
}
sp--;
}
}
} else {
if (Int_val(env->curr_char) == 0)
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
if (caml_parser_trace) fprintf(stderr, "Discarding last token read\n");
env->curr_char = Val_int(-1);
goto loop;
}
shift:
env->curr_char = Val_int(-1);
if (errflag > 0) errflag--;
shift_recover:
if (caml_parser_trace)
fprintf(stderr, "State %d: shift to state %d\n",
state, Short(tables->table, n2));
state = Short(tables->table, n2);
sp++;
if (sp < Long_val(env->stacksize)) goto push;
SAVE;
return GROW_STACKS_1;
/* The ML code resizes the stacks */
case STACKS_GROWN_1:
RESTORE;
push:
Field(env->s_stack, sp) = Val_int(state);
caml_modify(&Field(env->v_stack, sp), env->lval);
Store_field (env->symb_start_stack, sp, env->symb_start);
Store_field (env->symb_end_stack, sp, env->symb_end);
goto loop;
reduce:
if (caml_parser_trace)
fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
m = Short(tables->len, n);
env->asp = Val_int(sp);
env->rule_number = Val_int(n);
env->rule_len = Val_int(m);
sp = sp - m + 1;
m = Short(tables->lhs, n);
state1 = Int_val(Field(env->s_stack, sp - 1));
n1 = Short(tables->gindex, m);
n2 = n1 + state1;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == state1) {
state = Short(tables->table, n2);
} else {
state = Short(tables->dgoto, m);
}
if (sp < Long_val(env->stacksize)) goto semantic_action;
SAVE;
return GROW_STACKS_2;
/* The ML code resizes the stacks */
case STACKS_GROWN_2:
RESTORE;
semantic_action:
SAVE;
return COMPUTE_SEMANTIC_ACTION;
/* The ML code calls the semantic action */
case SEMANTIC_ACTION_COMPUTED:
RESTORE;
Field(env->s_stack, sp) = Val_int(state);
caml_modify(&Field(env->v_stack, sp), arg);
asp = Int_val(env->asp);
Store_field (env->symb_end_stack, sp, Field(env->symb_end_stack, asp));
if (sp > asp) {
/* This is an epsilon production. Take symb_start equal to symb_end. */
Store_field (env->symb_start_stack, sp, Field(env->symb_end_stack, asp));
}
goto loop;
default: /* Should not happen */
CAMLassert(0);
return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */
}
}
/* Control printing of debugging info */
CAMLprim value caml_set_parser_trace(value flag)
{
value oldflag = Val_bool(caml_parser_trace);
caml_parser_trace = Bool_val(flag);
return oldflag;
}
Reference in New Issue View Git Blame Copy Permalink