2
\$\begingroup\$

A few more rewrites down the line from my previous question, this is the C version 11 based on the PostScript prototype version 12. The PostScript version is shorter, but it's some crazy ass PostScript gibberish that's like my own private dialect, so translating to C makes it easier to share with the world. I showed off a little in comp.lang.c during the final round of debugging.

According to Greenspun's 10th rule:

Any sufficiently complicated C or Fortran program contains an ad hoc, informally-specified, bug-ridden, slow implementation of half of Common Lisp.

I've attempted to break this rule by explicitly adopting and crafting a much more modest fraction of Common Lisp. Just a tiny fraction. More like a Scheme, or a Lisp 1, with no (eval). There are lists of things which could be an integer or a string or a symbol or a parser or an operator or a list. There's just enough lazy evaluation to support lazy streams but then I got too lazy to carry it all the way through. So there's a careful handling of suspensions in the *object.[ch] module, but in the *parser.[ch] module it just forces the first item off of the input list in parse_satisfy() and all other parsers build upon that as their base. So, satisfy() parsers comprise the leaf nodes of the parser graph.

Building a recursive loop in a graph of parsers requires allocating a "forwarding parser", ie. an empty parser which can be composed in a graph with other parsers and then filled in later. Both the regex_grammar() and ebnf_grammar() functions use this technique to create parser graphs with loops in them. The print() and print_list() functions, when trying to print a parser will in some configurations print its saved environment. For many parser graphs, this will print out the whole graph in an awkward but informative format. But the printing functions take care not to dive into the saved environment of a parser that was constructed as a forward(), because it's very likely to lead to an infinite loop.

To simplify the usage code, many of the constructors -- Parser(), Operator(), Suspension() -- which take a function pointer to build a "function object", each try to capture a print name for the function at the same time. This is done by interfacing the constructor functions with macros that can make a copy of the function pointer argument and use the preprocessor's # stringify operation.

Another consequence of simplification is the use of environments. Parsers and Suspensions and Operator objects all contain a pointer to an environment -- ie. the saved, closed or curried values that accompany the function pointer. But in many cases I've seemed to "get away with" not actually using the environment pointer to hold an association list. For simple things like predicate operators the code just stores the values directly in the environment slot or a simple cons structure to hold a few values in a little tree. This approach seemed to help keep simple things simple.

Parser objects for the most part use the environment to hold association lists. And the into() and bind() parsers take some care to propagate environment information to their child functions. This is essential for the behavior of parser into( parser p, symbol id, parser q ) combinator. The parser resulting from this function must pass the result from executing the parser p into the parser q by defining it with the symbol id. The parser q in this case should be the result of parser bind( parser p, operator op ) so that the op can receive this value in its environment. For my own uses this feels like a safe restriction, but possibly it could limit the applicability of this code for certain applications that might need environment data to propagate around more, I guess.

As much as possible, I've tried to make the code read like pseudocode. So if you just look at the nouns and verbs in a line of code, that ought to give you some sense of what it's trying to do. The punctuation might get a little heavy in places, however.

The symbol type builds upon an enum for compile time symbols. So compile time symbols use the "code space" from 0 going up. That leaves EOF to resolve naturally to -1. And any dynamic symbols created by symbol symbol_from_string( string s ), if there are no previously allocated compile time symbols with the same printname, then a new dynamic symbol code is allocated in the code space from -2 going down. The effect of this can be seen in the test_ebnf() function. Any dynamically created symbols that arise from the productions string, in order to refer to them elsewhere in the code and have the symbol codes actually match, must be previously allocated. In the test_ebnf() function, in order to call assoc_symbol() on the result from the ebnf parser and actually get the start parser out of the association list, there must be a previous call to Symbol() with that enum name. So, if you were to comment out the call to Symbol(postal_address) from the beginning of the function it would fail at the end.

Any improvements to be made, to the interface or the implementation? I'd like to use this code to build compilers and interpreters for languages described by EBNF grammars. One notable missing feature is the ability to factor out left recursion from EBNF productions or parser graphs.

github

$ make count
wc pc11*[ch]
  437  1879 11141 pc11object.c
  101   517  3607 pc11object.h
  639  2496 16281 pc11parser.c
   81   322  1918 pc11parser.h
  169   685  4904 pc11test.c
 1427  5899 37851 total

Makefile

CFLAGS= -std=c99 -g -Wall -Wpedantic -Wextra -Wno-unused-function -Wno-unused-parameter -Wno-switch -Wno-return-type -Wunused-variable
CFLAGS+= $(cflags)

test : pc11
    ./$<

pc11 : pc11object.o pc11parser.o pc11test.o
    $(CC) $(CFLAGS) -o $@ $^ $(LDLIBS)

pc11object.o : pc11object.[ch]
pc11parser.o : pc11parser.[ch] pc11object.h
pc11test.o : pc11test.c pc11parser.h pc11object.h


clean :
    rm *.o

count :
    wc pc11*[ch]

ppnarg_h

/*
 * The PP_NARG macro evaluates to the number of arguments that have been
 * passed to it.
 *
 * Laurent Deniau, "__VA_NARG__," 17 January 2006, <comp.std.c> (29 November 2007).
 */
#define PP_NARG(...)    PP_NARG_(__VA_ARGS__,PP_RSEQ_N())
#define PP_NARG_(...)   PP_ARG_N(__VA_ARGS__)

#define PP_ARG_N( \
        _1, _2, _3, _4, _5, _6, _7, _8, _9,_10,  \
        _11,_12,_13,_14,_15,_16,_17,_18,_19,_20, \
        _21,_22,_23,_24,_25,_26,_27,_28,_29,_30, \
        _31,_32,_33,_34,_35,_36,_37,_38,_39,_40, \
        _41,_42,_43,_44,_45,_46,_47,_48,_49,_50, \
        _51,_52,_53,_54,_55,_56,_57,_58,_59,_60, \
        _61,_62,_63,_64,_65,_66,_67,_68,_69,_70, \
        _71,N,...) N

#define PP_RSEQ_N() \
        71,70, \
        69,68,67,66,65,64,63,62,61,60, \
        59,58,57,56,55,54,53,52,51,50, \
        49,48,47,46,45,44,43,42,41,40, \
        39,38,37,36,35,34,33,32,31,30, \
        29,28,27,26,25,24,23,22,21,20, \
        19,18,17,16,15,14,13,12,11,10, \
        9,8,7,6,5,4,3,2,1,0

pc11object.h

#define PC11OBJECT_H
#include <stdlib.h>
#include <stdio.h>
#include "ppnarg.h"

#define IS_THE_TARGET_OF_THE_HIDDEN_POINTER_  *
typedef union    object  IS_THE_TARGET_OF_THE_HIDDEN_POINTER_  object;
typedef object   integer;
typedef object   list;
typedef object   suspension;
typedef object   parser;
typedef object   operator;
typedef operator binoperator;
typedef operator predicate;
typedef object   symbol;
typedef object   string;
typedef object   boolean;
typedef object   fSuspension( object env );
typedef object   fParser( object env, list input );
typedef object   fOperator( object env, object input );
typedef boolean  fPredicate( object env, object input );
typedef object   fBinOperator( object left, object right );

enum object_symbol_codes {
  T,
  END_OBJECT_SYMBOLS
};

typedef enum {
  INVALID, INT, LIST, SUSPENSION, PARSER, OPERATOR, SYMBOL, STRING, VOID
} tag;

union object { tag t;
      struct { tag t; int i;                                             } Int;
      struct { tag t; object first, rest;                                } List;
      struct { tag t; object env; fSuspension *f; const char *printname; } Suspension;
      struct { tag t; object env; fParser *f; const char *printname;     } Parser;
      struct { tag t; object env; fOperator *f; const char *printname;   } Operator;
      struct { tag t; int code; const char *printname; object data;      } Symbol;
      struct { tag t; char *str; int disposable;                         } String;
      struct { tag t; object next; int forward;                          } Header;
      struct { tag t; void *pointer;                                     } Void;
};

extern object T_   /* = (union object[]){ {.t=1}, {.Symbol={SYMBOL, T, "T"}} } + 1 */,
              NIL_ /* = (union object[]){ {.t=INVALID} } */;

static int
valid( object it ){  // valid will also convert a boolean T_ or NIL_ to an integer 1 or 0
  return  it
      &&  it->t <= VOID
      &&  it->t != INVALID;
}

integer    Int( int i );
boolean    Boolean( int b );
list       one( object it );
list       cons( object first, object rest );
suspension Suspension_( object env, fSuspension *f, const char *printname );
#define    Suspension(env,f) Suspension_( env, f, __func__ )
parser     Parser_( object env, fParser *f, const char *printname );
#define    Parser(env,f) Parser_( env, f, __func__ )
operator   Operator_( object env, fOperator *f, const char *printname );
#define    Operator(env,f) Operator_( env, f, #f )
string     String( char *str, int disposable );
symbol     Symbol_( int code, const char *printname, object data );
#define    Symbol(n) Symbol_( n, #n, NIL_ )
object     Void( void *pointer );

int     length( list ls );
string  to_string( list ls );

void    print( object a );
void    print_list( object a );

object  first( list it );
list    rest( list it );
list    take( int n, list it );
list    drop( int n, list it );
object  apply( operator op, object it );

list    chars_from_str( char *str );
list    chars_from_file( FILE *file );
list    ucs4_from_utf8( list o );
list    utf8_from_ucs4( list o );

list    map( operator op, list it );
object  collapse( fBinOperator *f, list it );
object  reduce( fBinOperator *f, int n, object *po );
#define LIST(...) \
  reduce( cons, PP_NARG(__VA_ARGS__), (object[]){ __VA_ARGS__ } )

boolean eq( object a, object b );
boolean eq_symbol( int code, object b );

list    append( list start, list end );
list    env( list tail, int n, ... );
object  assoc( object key, list env );
object  assoc_symbol( int code, list env );

symbol  symbol_from_string( string s );

pc11object.c

#define _BSD_SOURCE
#include "pc11object.h"
#include <stdarg.h>
#include <string.h>

#define OBJECT(...) new_( (union object[]){{ __VA_ARGS__ }} )

object T_ = (union object[]){ {.t=1}, {.Symbol={SYMBOL, T, "T"}} } + 1,
       NIL_ = (union object[]){ {.t=INVALID} };

static object new_( object prototype );


integer
Int( int i ){
  return  OBJECT( .Int = { INT, i } );
}

boolean
Boolean( int b ){
  return  b  ? T_  : NIL_;
}

list
one( object it ){
  return  cons( it, NIL_ );
}

list
cons( object first, object rest ){
  return  OBJECT( .List = { LIST, first, rest } );
}

suspension
Suspension_( object env, fSuspension *f, const char *printname ){
  return  OBJECT( .Suspension = { SUSPENSION, env, f, printname } );
}

parser
Parser_( object env, fParser *f, const char *printname ){
  return  OBJECT( .Parser = { PARSER, env, f, printname } );
}

operator
Operator_( object env, fOperator *f, const char *printname ){
  return  OBJECT( .Operator = { OPERATOR, env, f, printname } );
}

string
String( char *str, int disposable ){
  return  OBJECT( .String = { STRING, str, disposable } );
}

symbol
Symbol_( int code, const char *printname, object data ){
  return  OBJECT( .Symbol = { SYMBOL, code, printname, data } );
}

object
Void( void *pointer ){
  return  OBJECT( .Void = { VOID, pointer } );
}


int
length( list ls ){
  return  valid( ls )  ?  valid( first( ls ) ) + length( rest( ls ) ) : 0;
}

int
string_length( object it ){
  switch(  it  ? it->t  : 0  ){
  default: return  0;
  case INT: return  1;
  case STRING: return  strlen( it->String.str );
  case LIST: return  string_length( first( it ) ) + string_length( rest( it ) );
  }
}

void
fill_string( char **str, list it ){
  switch(  it  ? it->t  : 0  ){
  default: return;
  case INT:
    *(*str)++ = it->Int.i;
    return;
  case STRING:
    strcpy( *str, it->String.str );
    *str += strlen( it->String.str );
    return;
  case LIST:
    fill_string( str, first( it ) );
    fill_string( str, rest( it ) );
    return;
  }
}

string
to_string( list ls ){
  char *str = calloc( 1 + string_length( ls ), 1 );
  string s = OBJECT( .String = { STRING, str, 1 } );
  fill_string( &str, ls );
  return  s;
}

static int print_innards = 1;
static int print_chars = 1;
static int print_codes = 0;

void
print( object a ){
  switch(  a  ? a->t  : 0  ){
  default: printf( "() " ); break;
  case INT: printf( print_chars  ? "'%c' "  : "%d ", a->Int.i ); break;
  case LIST: printf( "(" ), print( a->List.first ), printf( "." ),
                            print( a->List.rest ), printf( ")" ); break;
  case SUSPENSION: printf( "...(%s) ", a->Suspension.printname ); break;
  case PARSER: printf( "Parser(%s", a->Parser.printname ),
               (print_innards & ! a[-1].Header.forward) &&
                 (printf( ", " ), print( a->Parser.env ),0),
               printf( ") " ); break;
  case OPERATOR: printf( "Oper(%s", a->Operator.printname ),
                 printf( ", " ), print( a->Operator.env ),
                 printf( ") " ); break;
  case STRING: printf( "\"%s\" ", a->String.str ); break;
  case SYMBOL: if(  print_codes  )
                 printf( "%d:%s ", a->Symbol.code, a->Symbol.printname );
               else
         printf( "%s ", a->Symbol.printname );
               break;
  case VOID: printf( "VOID " ); break;
  }
}


static void
print_listn( object a ){
  if(  ! valid( a )  ) return;
  switch(  a->t  ){
  default: print( a ); break;
  case LIST: print_list( first( a ) ),
             print_listn( rest( a ) ); break;
  }
}

void
print_list( object a ){
  switch(  a  ? a->t  : 0  ){
  default: print( a ); break;
  case LIST: printf( "(" ), print_list( first( a ) ),
                            print_listn( rest( a ) ), printf( ") " ); break;
  }
}


object
force_( object it ){
  if(  it->t != SUSPENSION  ) return  it;
  return  force_( it->Suspension.f( it->Suspension.env ) );
}


static object force_first ( object it ){ \
  *it = *force_( it ); \
  return  first( it ); \
} \
object first( list it ){ \
  if(  it->t == SUSPENSION  ) return  Suspension( it, force_first );
  if(  it->t != LIST  ) return  NIL_;
  return  it->List.first;
}

static object force_rest ( object it ){ \
  *it = *force_( it ); \
  return  rest( it ); \
} \
object rest( list it ){ \
  if(  it->t == SUSPENSION  ) return  Suspension( it, force_rest );
  if(  it->t != LIST  ) return  NIL_;
  return  it->List.rest;
}


list
take( int n, list it ){
  if(  n == 0  ) return  NIL_;
  *it = *force_( it );
  if(  ! valid( it )  ) return  NIL_;
  return  cons( first( it ), take( n-1, rest( it ) ) );
}

list
drop( int n, list it ){
  if(  n == 0  ) return  it;
  *it = *force_( it );
  if(  ! valid( it )  ) return  NIL_;
  return  drop( n-1, rest( it ) );
}


static object
force_apply( list env ){
  operator op = first( env );
  object it = rest( env );
  *it = *force_( it );
  return  apply( op, it );
}

object
apply( operator op, object it ){
  if(  it->t == SUSPENSION  ) return  Suspension( cons( op, it ), force_apply );
  return  op->Operator.f( op->Operator.env, it );
}


static list
force_chars_from_string( string s ){
  char *str = s->String.str;
  if(  ! *str  ) return  one( Symbol( EOF ) );
  return  cons( Int( *str ), Suspension( String( str+1, 0 ), force_chars_from_string ) );
}

list
chars_from_str( char *str ){
  if(  ! str  ) return  NIL_;
  return  Suspension( String( str, 0 ), force_chars_from_string );
}


static list
force_chars_from_file( object file ){
  FILE *f = file->Void.pointer;
  int c = fgetc( f );
  if(  c == EOF  ) return  one( Symbol( EOF ) );
  return  cons( Int( c ), Suspension( file, force_chars_from_file ) );
}

list
chars_from_file( FILE *file ){
  if(  ! file  ) return  NIL_;
  return  Suspension( Void( file ), force_chars_from_file );
}

static int
leading_ones( object byte ){
  if(  byte->t != INT  ) return  0;
  int x = byte->Int.i;
  return  x&0x80 ? x&0x40 ? x&0x20 ? x&0x10 ? x&8 ? x&4 ? 6
                                                    : 5
                                              : 4
                                     : 3
                            : 2
                   : 1
          : 0;
}

static int
mask_off( object byte, int m ){
  if(  byte->t != INT  ) return  0;
  int x = byte->Int.i;
  return  x & (m? (1<<(8-m))-1 :-1);
}

static list
force_ucs4_from_utf8( list input ){
  *input = *force_( input );
  object byte;
  byte = first( input ), input = rest( input );
  if(  !valid(byte)  ) return  NIL_;
  if(  eq_symbol( EOF, byte )  ) return  input;
  int ones = leading_ones( byte );
  int bits = mask_off( byte, ones );
  int n = ones;
  while(  n-- > 1  ){
    *input = *force_( input );
    byte = first( input ), input = rest( input );
    if(  eq_symbol( EOF, byte )  ) return  input;
    bits = ( bits << 6 ) | ( byte->Int.i & 0x3f );
  }
  if(  bits < ((int[]){0,0,0x80,0x800,0x10000,0x110000,0x4000000})[ ones ]  )
    fprintf( stderr, "Overlength encoding in utf8 char.\n" );
  return  cons( Int( bits ), Suspension( input, force_ucs4_from_utf8 ) );
}

list
ucs4_from_utf8( list input ){
  if(  ! input  ) return  NIL_;
  return  Suspension( input, force_ucs4_from_utf8 );
}


static list
force_utf8_from_ucs4( list input ){
  *input = *force_( input );
  object code = first( input );
  if(  eq_symbol( EOF, code )  ) return  input;
  int x = code->Int.i;
  object next = Suspension( drop( 1, input ), force_utf8_from_ucs4 );
  if(  x <= 0x7f  )
    return  cons( code, next );
  if(  x <= 0x7ff  )
    return  LIST( Int( (x >> 6)   | 0xc0 ),
                  Int( (x & 0x3f) | 0x80 ), next );
  if(  x <= 0xffff )
    return  LIST( Int(   (x >> 12)         | 0xe0 ),
                  Int( ( (x >> 6) & 0x3f ) | 0x80 ),
              Int( (  x       & 0x3f ) | 0x80 ), next );
  if(  x <= 0x10ffff  )
    return  LIST( Int(   (x >> 18)          | 0xf0 ),
              Int( ( (x >> 12) & 0x3f ) | 0x80 ),
                  Int( ( (x >> 6)  & 0x3f ) | 0x80 ),
              Int( (  x        & 0x3f ) | 0x80 ), next );
  if(  x <= 0x3ffffff  )
    return  LIST( Int(   (x >> 24)          | 0xf8 ),
              Int( ( (x >> 18) & 0x3f ) | 0x80 ),
              Int( ( (x >> 12) & 0x3f ) | 0x80 ),
                  Int( ( (x >> 6)  & 0x3f ) | 0x80 ),
              Int( (  x        & 0x3f ) | 0x80 ), next );
  if(  x <= 0x3fffffff  )
    return  LIST( Int(   (x >> 30)          | 0xfc ),
              Int( ( (x >> 24) & 0x3f ) | 0x80 ),
              Int( ( (x >> 18) & 0x3f ) | 0x80 ),
              Int( ( (x >> 12) & 0x3f ) | 0x80 ),
                  Int( ( (x >> 6)  & 0x3f ) | 0x80 ),
              Int( (  x        & 0x3f ) | 0x80 ), next );
  fprintf( stderr, "Invalid unicode code point in ucs4 char.\n" );
  return  next;
}

list
utf8_from_ucs4( list input ){
  if(  ! input  ) return  NIL_;
  return  Suspension( input, force_utf8_from_ucs4 );
}


list
map( operator op, list it ){
  if(  ! valid( it )  ) return  it;
  return  cons( apply( op, first( it ) ),
        map( op, rest( it ) ) );
}

object
collapse( fBinOperator *f, list it ){
  if(  !valid( it )  ) return  it;
  object right = collapse( f, rest( it ) );
  if(  !valid( right )  ) return  first( it );
  return  f( first( it ), right );
}

object
reduce( fBinOperator *f, int n, object *po ){
  return  n==1  ? *po  : f( *po, reduce( f, n-1, po+1 ) );
}


boolean
eq( object a, object b ){
  return  Boolean(
            !valid( a ) && !valid( b )  ? 1  :
            !valid( a ) || !valid( b )  ? 0  :
            a->t != b->t                ? 0  :
            a->t == SYMBOL              ? a->Symbol.code == b->Symbol.code  :
            !memcmp( a, b, sizeof *a )  ? 1  : 0
          );
}

boolean
eq_symbol( int code, object b ){
  return  eq( (union object[]){ {.Symbol = {SYMBOL, code, "", 0} } }, b );
}

list
append( list start, list end ){
  if(  ! valid( start )  ) return  end;
  return  cons( first( start ), append( rest( start ), end ) );
}

list
env( list tail, int n, ... ){
  va_list v;
  va_start( v, n );
  list r = tail;
  while( n-- ){
    object a = va_arg( v, object );
    object b = va_arg( v, object );
    r = cons( cons( a, b ), r );
  }
  va_end( v );
  return  r;
}

object
assoc( object key, list b ){
  if(  !valid( b )  ) return  NIL_;
  object pair = first( b );
  if(  valid( eq( key, first( pair ) ) )  )
    return  rest( pair );
  else
    return  assoc( key, rest( b ) );
}

object
assoc_symbol( int code, list b ){
  return  assoc( (union object[]){ {.Symbol = {SYMBOL, code, "", 0}} }, b );
}



static list allocation_list = NULL;

static object
new_( object prototype ){
  object record = calloc( 2, sizeof *record );
  if(  record  ){
    record[0] = (union object){ .Header = { 0, allocation_list } };
    allocation_list = record;
    record[1] = *prototype;
  }
  return  record + 1;
}

static int next_symbol_code = -2;

symbol
symbol_from_string( string s ){
  list ls = allocation_list;
  while(  ls != NULL && valid( ls + 1 )  ){
    if(  ls[1].t == SYMBOL
    &&  strcmp( ls[1].Symbol.printname, s->String.str ) == 0  ){
      return  ls + 1;
    }
    ls = ls[0].Header.next;
  }
  return  Symbol_( next_symbol_code--, strdup( s->String.str ), NIL_ );
}

pc11parser.h

#define PC11PARSER_H
#if ! PC11OBJECT_H
  #include "pc11object.h"
#endif

enum parser_symbol_codes {
  VALUE = END_OBJECT_SYMBOLS,
  OK,
  FAIL,
  SATISFY_PRED,
  EITHER_P,
  EITHER_Q,
  SEQUENCE_P,
  SEQUENCE_Q,
  SEQUENCE_OP,
  BIND_P,
  BIND_OP,
  INTO_P,
  INTO_ID,
  INTO_Q,
  ATOM,
  PROBE_P,
  PROBE_MODE,
  SEQ,
  ANY,
  EPSILON,
  MAYBE,
  MANY,
  END_PARSER_SYMBOLS
};

list    parse( parser p, list input );

int     is_ok( list result );
int     not_ok( list result );
parser  succeeds( list result );
parser  fails( list errormsg );
parser  satisfy( predicate pred );
parser  alpha( void );
parser  upper( void );
parser  lower( void );
parser  digit( void );
parser  literal( object example );
parser  chr( int c );
parser  str( char *s );
parser  anyof( char *s );
parser  noneof( char *s );
parser  either( parser p, parser q );
#define ANY(...) reduce( either, PP_NARG(__VA_ARGS__), (object[]){ __VA_ARGS__ } )
parser  sequence( parser p, parser q, binoperator op );
parser  xthen( parser p, parser q );
parser   thenx( parser p, parser q );
parser   then( parser p, parser q );
#define SEQ(...) reduce( then, PP_NARG(__VA_ARGS__), (object[]){ __VA_ARGS__ } )
parser  forward( void );
parser  maybe( parser p );
parser  many( parser p );
parser  some( parser p );
parser  item( void );
parser  probe( parser p, int mode ); //print on ok iff mode&1, print not ok iff mode&2

parser  bind( parser p, operator op );
parser  into( parser p, object id, parser q );

// E->T ('|' T)*
// T->F*
// F->A ('*' | '+' | '?')?
// A->'.' | '('E')' | C
// C->S|L|P
// S->'\' ('.' | '|' | '(' | ')' | '[' | ']' | '/' )
// L->'[' '^'? ']'? [^]]* ']'
// P->Plain char
parser  regex( char *re );

// D->N '=' E ';'
// N->name
// E->T ('|' T)*
// T->F*
// F->R | N | '[' E ']' | '{' E '}' | '(' E ')' | '/' regex '/'
// R->'"' [^"]* '"' | "'" [^']* "'"
list    ebnf( char *productions, list supplements, list handlers );

pc11parser.c

#include "pc11parser.h"
#include <ctype.h>
#include <string.h>

list
parse( parser p, list input ){
  if(  !valid( p ) || !valid( input ) || p->t != PARSER  )
    return  LIST( Symbol( FAIL ), String("parse() validity check failed",0), input ); 
  return  p->Parser.f( p->Parser.env, input );
}


static object
success( object v, list input ){
  return  cons( Symbol( OK ), cons( v, input ) );
}

static object
fail( object v, list input ){
  return  cons( Symbol( FAIL ), cons( v, input ) );
}


int
is_ok( list result ){
  return  valid( eq_symbol( OK, first( result ) ) );
}

int
not_ok( list result ){
  return  ! is_ok( result );
}


parser
succeeds( list result ){
  return  Parser( result, success );
}

parser
fails( list errormsg ){
  return  Parser( errormsg, fail );
}


static list
parse_satisfy( object env, list input ){
  predicate pred = assoc_symbol( SATISFY_PRED, env );
  drop( 1, input );
  object item = first( input );
  if(  ! valid( item )  ) return  fail( String( "empty input", 0 ), input );
  return  valid( apply( pred, item ) )
            ? success( item, rest( input ) )
            : fail( LIST( String( "predicate not satisfied", 0 ), pred, NIL_ ), input );
}

parser
satisfy( predicate pred ){
  return  Parser( env( NIL_, 1, Symbol(SATISFY_PRED), pred ), parse_satisfy );
}


boolean
always_true( object v, object it ){
  return  T_;
}

parser item( void ){
  return  satisfy( Operator( NIL_, always_true ) );
}


static boolean
is_alpha( object v, object it ){
  return  Boolean( it->t == INT && isalpha( it->Int.i ) );
}

parser
alpha( void ){
  return  satisfy( Operator( NIL_, is_alpha ) );
}


static boolean
is_upper( object v, object it ){
  return  Boolean( it->t == INT && isupper( it->Int.i ) );
}

parser
upper( void ){
  return  satisfy( Operator( NIL_, is_upper ) );
}


static boolean
is_lower( object v, object it ){
  return  Boolean( it->t == INT && islower( it->Int.i ) );
}

parser
lower( void ){
  return  satisfy( Operator( NIL_, is_lower ) );
}


static boolean
is_digit( object v, object it ){
  return  Boolean( it->t == INT && isdigit( it->Int.i ) );
}

parser
digit( void ){
  return  satisfy( Operator( NIL_, is_digit ) );
}


static boolean
is_literal( object example, object it ){
  return  eq( example, it );
}

parser
literal( object example ){
  return  satisfy( Operator( example, is_literal ) );
}


parser
chr( int c ){
  return  literal( Int( c ) );
}


parser
str( char *s ){
  return  !*s  ? succeeds( NIL_ )
               : s[1]  ? then( chr( *s ), str( s+1 ) )
                       : chr( *s );
}


static boolean
is_range( object bounds, object it ){
  int lo = first( bounds )->Int.i,
      hi = rest( bounds )->Int.i;
  return  Boolean( it->t == INT && lo <= it->Int.i && it->Int.i <= hi );
}

parser
range( int lo, int hi ){
  return  satisfy( Operator( cons( Int( lo ), Int( hi ) ), is_range ) );
}


static boolean
is_anyof( object set, object it ){
  return  Boolean( it->t == INT && strchr( set->String.str, it->Int.i ) != NULL );
}

parser
anyof( char *s ){
  return  satisfy( Operator( String( s, 0 ), is_anyof ) );
}


static boolean
is_noneof( object set, object it ){
  return  Boolean( it->t == INT && strchr( set->String.str, it->Int.i ) == NULL );
}

parser
noneof( char *s ){
  return  satisfy( Operator( String( s, 0 ), is_noneof ) );
}


static object
parse_either( object env, list input ){
  parser p = assoc_symbol( EITHER_P, env );
  object result = parse( p, input );
  if(  is_ok( result )  ) return  result;
  parser q = assoc_symbol( EITHER_Q, env );
  return  parse( q, input );
}

parser
either( parser p, parser q ){
  return  Parser( env( NIL_, 2,
               Symbol(EITHER_Q), q,
                       Symbol(EITHER_P), p ),
                  parse_either );
}


static object
parse_sequence( object env, list input ){
  parser p = assoc_symbol( SEQUENCE_P, env );
  object p_result = parse( p, input );
  if(  not_ok( p_result )  ) return  p_result;

  parser q = assoc_symbol( SEQUENCE_Q, env );
  list remainder = rest( rest( p_result ) );
  object q_result = parse( q, remainder );
  if(  not_ok( q_result )  ){
    object q_error = first( rest( q_result ) );
    object q_remainder = rest( rest( q_result ) );
    return  fail( LIST( q_error, String( "after", 0), first( rest( p_result ) ), NIL_ ),
          q_remainder );
  }

  binoperator op = assoc_symbol( SEQUENCE_OP, env );
  return  success( op->Operator.f( first( rest( p_result ) ),
                                   first( rest( q_result ) ) ),
                   rest( rest( q_result ) ) );
}

parser
sequence( parser p, parser q, binoperator op ){
  return  Parser( env( NIL_, 3,
                       Symbol(SEQUENCE_OP), op,
                       Symbol(SEQUENCE_Q), q,
                       Symbol(SEQUENCE_P), p ),
                  parse_sequence );
}


static object
concat( object l, object r ){
  if(  ! valid( l )  ) return  r;
  if(  r->t == LIST
    && valid( eq_symbol( VALUE, first( first( r ) ) ) )
    && ! valid( rest( r ) )
    && ! valid( rest( first( r ) ) )  )
    return  l;
  switch(  l->t  ){
  case LIST: return  cons( first( l ), concat( rest( l ), r ) );
  default: return  cons( l, r );
  }
}

parser
then( parser p, parser q ){
  return  sequence( p, q, Operator( NIL_, concat ) );
}


static object
left( object l, object r ){
  return  l;
}

static object
right( object l, object r ){
  return  r;
}

parser
xthen( parser p, parser q ){
  return  sequence( p, q, Operator( NIL_, right ) );
}

parser
thenx( parser p, parser q ){
  return  sequence( p, q, Operator( NIL_, left ) );
}


parser
forward( void ){
  parser p = Parser( 0, 0 );
  p[-1].Header.forward = 1;
  return  p;
}


parser
maybe( parser p ){
  return  either( p, succeeds( NIL_ ) );
}


parser
many( parser p ){
  parser q = forward();
  *q = *maybe( then( p, q ) );
  return  q;
}


parser
some( parser p ){
  return  then( p, many( p ) );
}


static object
parse_bind( object env, list input ){
  parser p = assoc_symbol( BIND_P, env );
  operator op = assoc_symbol( BIND_OP, env );
  object result = parse( p, input );
  if(  not_ok( result )  ) return  result;
  object payload = rest( result ),
         value = first( payload ),
         remainder = rest( payload );
  return  success( apply( (union object[]){{.Operator={
    OPERATOR, append(op->Operator.env, env), op->Operator.f, op->Operator.printname
  }}}, value ), remainder );
}

parser
bind( parser p, operator op ){
  return  Parser( env( NIL_, 2,
                       Symbol(BIND_P), p,
                       Symbol(BIND_OP), op ),
                  parse_bind );
}


static object
parse_into( object v, list input ){
  parser p = assoc_symbol( INTO_P, v );
  object p_result = parse( p, input );
  if(  not_ok( p_result )  ) return  p_result;
  object id = assoc_symbol( INTO_ID, v );
  parser q = assoc_symbol( INTO_Q, v );
  object q_result = q->Parser.f( env( q->Parser.env, 1,
                                      id, first( rest( p_result ) ) ),
                         rest( rest( p_result ) ) );
  if(  not_ok( q_result )  ){
    object q_error = first( rest( q_result ) );
    object q_remainder = rest( rest( q_result ) );
    return  fail( LIST( q_error, String( "after", 0), first( rest( p_result ) ), NIL_ ),
          q_remainder );
  }
  return  q_result;
}

parser
into( parser p, object id, parser q ){
  return  Parser( env( NIL_, 3,
                       Symbol(INTO_P), p,
                       Symbol(INTO_ID), id,
                       Symbol(INTO_Q), q ),
                  parse_into );
}


object
parse_probe( object env, object input ){
  parser p = assoc_symbol( PROBE_P, env );
  int mode = assoc_symbol( PROBE_MODE, env )->Int.i;
  object result = parse( p, input );
  if(  is_ok( result ) && mode&1  )
    print( result ), puts("");
  else if(  not_ok( result ) && mode&2  )
    print_list( result ), puts("");
  return  result;
}

parser
probe( parser p, int mode ){
  return  Parser( env( NIL_, 2, Symbol(PROBE_MODE), Int( mode ), Symbol(PROBE_P), p ),
          parse_probe );
}


static parser
apply_meta( parser a, object it ){
  switch(  it->Int.i  ){
  default:  return  a;
  case '*': return  many( a );
  case '+': return  some( a );
  case '?': return  maybe( a );
  }
}

static parser
on_dot( object v, object it ){
  return  item();
}

static parser
on_chr( object v, object it ){
  return  literal( it );
}

static parser
on_meta( object v, object it ){
  parser atom = assoc_symbol( ATOM, v );
  if(  it->t == LIST 
    && valid( eq_symbol( VALUE, first( first( it ) ) ) )
    && ! valid( rest( it ) )
    && ! valid( rest( rest( it ) ) )  )
    return  atom;
  return  apply_meta( atom, it );
}

static parser
on_class( object v, object it ){
  if(  first( it )->Int.i == '^'  )
    return  satisfy( Operator( to_string( rest( it ) ), is_noneof ) );
  return  satisfy( Operator( to_string( it ), is_anyof ) );
}

static parser
on_term( object v, object it ){
  if(  ! valid( it )  ) return  NIL_;
  if(  it->t == LIST  &&  ! valid( rest( it ) )  ) it = first( it ); 
  if(  it->t == PARSER  ) return  it;
  return  collapse( then, it );
}

static parser
on_expr( object v, object it ){
  if(  it->t == LIST  &&  ! valid( rest( it ) )  ) it = first( it );
  if(  it->t == PARSER  ) return  it;
  return  collapse( either, it );
}

#define META     "*+?"
#define SPECIAL  META ".|()[]/"

static parser
regex_grammar( void ){
  parser dot       = bind( chr('.'), Operator( NIL_, on_dot ) );
  parser meta      = anyof( META );
  parser escape    = xthen( chr('\\'), anyof( SPECIAL "\\" ) );
  parser class     = xthen( chr('['),
                thenx( SEQ( maybe( chr('^') ),
                            maybe( chr(']') ),
                                        many( noneof( "]" ) ) ),
                       chr(']') ) );
  parser character = ANY( bind( escape, Operator( NIL_, on_chr ) ),
              bind( class, Operator( NIL_, on_class ) ),
              bind( noneof( SPECIAL ), Operator( NIL_, on_chr ) ) );
  parser expr      = forward();
  {
    parser atom    = ANY( dot,
                          xthen( chr('('), thenx( expr, chr(')') ) ),
                          character );
    parser factor  = into( atom, Symbol(ATOM),
                           bind( maybe( meta ),
                                 Operator( NIL_, on_meta ) ) );
    parser term    = bind( many( factor ),
                           Operator( NIL_, on_term ) );
    *expr  = *bind( then( term, many( xthen( chr('|'), term ) ) ),
                    Operator( NIL_, on_expr ) );
  }
  return  expr;
}


static parser regex_parser;

parser
regex( char *re ){
  if(  !regex_parser  ) regex_parser = regex_grammar();
  object result = parse( regex_parser, chars_from_str( re ) );
  if(  not_ok( result )  ) return  result;
  return  first( rest( result ) );
}


static string
stringify( object env, object input ){
  return  to_string( input );
}

static symbol
symbolize( object env, object input ){
  return  symbol_from_string( to_string( input ) );
}

static list
encapsulate( object env, object input ){
  return  one( input );
}


static parser
make_matcher( object env, object input ){
  return  str( to_string( input )->String.str );
}

static list
make_sequence( object env, object input ){
  if(  length( input ) == 0  ) return  Symbol( EPSILON );
  if(  length( input ) < 2  ) return  input;
  return  one( cons( Symbol( SEQ ), input ) );
}

static list
make_any( object env, object input ){
  if(  length( input ) < 2  ) return  input;
  return  one( cons( Symbol( ANY ), input ) );
}

static list
make_maybe( object env, object input ){
  return  one( cons( Symbol( MAYBE ), input ) );
}

static list
make_many( object env, object input ){
  return  one( cons( Symbol( MANY ), input ) );
}


static parser
ebnf_grammar( void ){
  if(  !regex_parser  ) regex_parser = regex_grammar();
  parser spaces = many( anyof( " \t\n" ) );
  parser defining_symbol = thenx( chr( '=' ), spaces );
  parser choice_symbol = thenx( chr( '|' ), spaces );
  parser terminating_symbol = thenx( chr( ';' ), spaces );
  parser name = some( either( anyof( "-_" ), alpha() ) );
  parser identifier = thenx( name, spaces );
  parser terminal =
    bind( 
      thenx( either( thenx( xthen( chr( '"'), many( noneof("\"") ) ), chr( '"') ),
                     thenx( xthen( chr('\''), many( noneof( "'") ) ), chr('\'') ) ),
             spaces ),
      Operator( NIL_, make_matcher ) );
  parser symb = bind( identifier, Operator( NIL_, symbolize ) );
  parser nonterminal = symb;
  parser expr = forward();
  {
    parser factor = ANY( terminal,
             nonterminal,
             bind( xthen( then( chr( '[' ), spaces ),
                      thenx( expr,
                         then( chr( ']' ), spaces ) ) ),
                   Operator( NIL_, make_maybe ) ),
             bind( xthen( then( chr( '{' ), spaces ),
                                      thenx( expr,
                         then( chr( '}' ), spaces ) ) ),
                               Operator( NIL_, make_many ) ),
                         bind( xthen( then( chr( '(' ), spaces ),
                      thenx( expr,
                             then( chr( ')' ), spaces ) ) ),
                               Operator( NIL_, encapsulate ) ),
                         bind( xthen( chr( '/' ),
                                      thenx( regex_parser, chr( '/' ) ) ),
                               Operator( NIL_, encapsulate ) ) );
    parser term = bind( many( factor ), Operator( NIL_, make_sequence ) );
    *expr = *bind( then( term, many( xthen( choice_symbol, term ) ) ),
           Operator( NIL_, make_any ) );
  };
  parser definition = bind( then( symb,
                xthen( defining_symbol,
                   thenx( expr, terminating_symbol ) ) ),
                Operator( NIL_, encapsulate) );
  return  some( definition );
}


static list
define_forward( object env, object it ){
  if(  rest( it )->t == PARSER  ) return  it;
  return  cons( first( it ), forward() );
}

static parser
compile_bnf( object env, object it ){
  switch(  it->t  ){
  default:
    return  it;
  case SYMBOL: {
    object ob = assoc( it, env );
    return  valid( ob )  ? ob  : it;
  }
  case LIST:   {
    object f = first( it );
    if(  valid( eq_symbol( SEQ, f ) )  )
      return  collapse( then,
          map( (union object[]){{.Operator={OPERATOR,env,compile_bnf}}},
           rest( it ) ) );
    if(  valid( eq_symbol( ANY, f ) )  )
      return  collapse( either,
      map( (union object[]){{.Operator={OPERATOR,env,compile_bnf}}},
           rest( it ) ) );
    if(  valid( eq_symbol( MANY, f ) )  )
      return  many( map( (union object[]){{.Operator={OPERATOR,env,compile_bnf}}},
                         rest( it ) ) );
    if(  valid( eq_symbol( MAYBE, f ) )  )
      return  maybe( map( (union object[]){{.Operator={OPERATOR,env,compile_bnf}}},
                           rest( it ) ) );
    return  map( (union object[]){{.Operator={OPERATOR,env,compile_bnf}}},
         it );
  }
  }
}

static list
compile_rhs( object env, object it ){
  if(  rest( it )->t == PARSER  ) return  it;
  object result = cons( first( it ),
      map( (union object[]){{.Operator={OPERATOR,env,compile_bnf}}}, rest( it ) ) );
  return  result;
}

static list
define_parser( object env, object it ){
  object lhs = assoc( first( it ), env );
  if(  valid( lhs ) && lhs->t == PARSER && lhs->Parser.f == NULL  ){
    object rhs = rest( it );
    if(  rhs->t == LIST  ) rhs = first( rhs );
    *lhs = *rhs;
  }
  return  it;
}

static list
wrap_handler( object env, object it ){
  object lhs = assoc( first( it ), env );
  if(  valid( lhs ) && lhs->t == PARSER  ){
    object op = rest( it );
    parser copy = Parser( 0, 0 );
    *copy = *lhs;
    *lhs = *bind( copy, op );
  }
  return  it;
}


list
ebnf( char *productions, list supplements, list handlers ){
  static parser ebnf_parser;
  if(  !ebnf_parser  ) ebnf_parser = ebnf_grammar();
  object result = parse( ebnf_parser, chars_from_str( productions ) );
  if(  not_ok( result )  ) return  result;
  object payload = first( rest( result ) );
  list defs = append( payload, env( supplements, 1, Symbol(EPSILON), succeeds(NIL_) ) );
  list forwards = map( Operator( NIL_, define_forward ), defs );
  list parsers = map( Operator( forwards, compile_rhs ), defs );
  list final = map( Operator( forwards, define_parser ), parsers );
  map( Operator( forwards, wrap_handler ), handlers );
  return  final;
}

pc11test.c

#include "pc11parser.h"

enum test_symbol_codes {
  TEST = END_PARSER_SYMBOLS,
  DIGIT,
  UPPER,
  NAME,
  NUMBER,
  EOL,
  SP,
  postal_address,
  name_part,
  street_address,
  street_name,
  zip_part,
  END_TEST_SYMBOLS
};

static int test_basics();
static int test_parsers();
static int test_regex();
static int test_ebnf();

int main( void ){
  return  test_basics()
      ||  test_parsers()
      ||  test_regex()
      ||  test_ebnf();
}

static int
test_basics(){
  puts( __func__ );
  list ch = chars_from_str( "abcdef" );
    print( ch ), puts("");       // print with dot notation
    print_list( ch ), puts("");  // print with list notation
  drop( 6, ch );                 // force first 6 elements of stream
    print( ch ), puts("");
    print_list( ch ), puts("");
  drop( 7, ch );
    print( ch ), puts("");
    print_list( ch ), puts("");
  puts("");
  return  0;
}

static int
test_parsers(){
  puts( __func__ );
  list ch = chars_from_str( "a b c d 1 2 3 4" );
  parser p = succeeds( Int('*') );
    print_list( parse( p, ch ) ), puts("");
  parser q = fails( String("Do you want a cookie?",0) );
    print_list( parse( q, ch ) ), puts("");
  parser r = item();
    print_list( parse( r, ch ) ), puts("");
  parser s = either( alpha(), item() );
    print_list( parse( s, ch ) ), puts("");
  parser t = literal( Int('a') );
    print_list( parse( t, ch ) ), puts("");
  puts("");
  return  0;
}

static int
test_regex(){
  puts( __func__ );
  parser a = regex( "." );
  print_list( a ), puts("");
  print_list( parse( a, chars_from_str( "a" ) ) ), puts("");
  print_list( parse( a, chars_from_str( "." ) ) ), puts("");
  print_list( parse( a, chars_from_str( "\\." ) ) ), puts("");
  puts("");

  parser b = regex( "\\." );
  print_list( b ), puts("");
  print_list( parse( b, chars_from_str( "a" ) ) ), puts("");
  print_list( parse( b, chars_from_str( "." ) ) ), puts("");
  print_list( parse( b, chars_from_str( "\\." ) ) ), puts("");
  puts("");

  parser c = regex( "\\\\." );
  print_list( c ), puts("");
  print_list( parse( c, chars_from_str( "a" ) ) ), puts("");
  print_list( parse( c, chars_from_str( "." ) ) ), puts("");
  print_list( parse( c, chars_from_str( "\\." ) ) ), puts("");
  print_list( parse( c, chars_from_str( "\\a" ) ) ), puts("");
  puts("");

  parser d = regex( "\\\\\\." );
  print_list( d ), puts("");
  print_list( parse( d, chars_from_str( "a" ) ) ), puts("");
  print_list( parse( d, chars_from_str( "." ) ) ), puts("");
  print_list( parse( d, chars_from_str( "\\." ) ) ), puts("");
  print_list( parse( d, chars_from_str( "\\a" ) ) ), puts("");
  puts("");

  parser e = regex( "\\\\|a" );
  print_list( e ), puts("");
  print_list( parse( e, chars_from_str( "a" ) ) ), puts("");
  print_list( parse( e, chars_from_str( "." ) ) ), puts("");
  print_list( parse( e, chars_from_str( "\\." ) ) ), puts("");
  print_list( parse( e, chars_from_str( "\\a" ) ) ), puts("");
  puts("");
  
  parser f = regex( "[abcd]" );
  print_list( f ), puts("");
  print_list( parse( f, chars_from_str( "a" ) ) ), puts("");
  print_list( parse( f, chars_from_str( "." ) ) ), puts("");
  puts("");

  return  0;
}

static object
stringify( object env, object it ){
  return  to_string( it );
}

static int
test_ebnf(){
  puts( __func__ );
  Symbol(postal_address);
  Symbol(name_part);
  Symbol(street_address);
  Symbol(street_name);
  Symbol(zip_part);

  list parsers = ebnf(
    "postal_address = name_part street_address zip_part ;\n"
    "name_part = personal_part SP last_name SP opt_suffix_part EOL\n"
    "          | personal_part SP name_part ;\n"
    "personal_part = initial '.' | first_name ;\n"
    "street_address = house_num SP street_name opt_apt_num EOL ;\n"
    "zip_part = town_name ',' SP state_code SP zip_code EOL ;\n"
    "opt_suffix_part = 'Sr.' | 'Jr.' | roman_numeral | ;\n"
    "opt_apt_num = [ apt_num ] ;\n"
    "apt_num = NUMBER ;\n"
    "town_name = NAME ;\n"
    "state_code = UPPER UPPER ;\n"
    "zip_code = DIGIT DIGIT DIGIT DIGIT DIGIT ;\n"
    "initial = 'Mrs' | 'Mr' | 'Ms' | 'M' ;\n"
    "roman_numeral = 'I' [ 'V' | 'X' ] { 'I' } ;\n"
    "first_name = NAME ;\n"
    "last_name = NAME ;\n"
    "house_num = NUMBER ;\n"
    "street_name = NAME ;\n",
    env( NIL_, 6,
     Symbol(EOL), chr('\n'),
     Symbol(DIGIT), digit(),
     Symbol(UPPER), upper(),
     Symbol(NUMBER), some( digit() ),
         Symbol(NAME), some( alpha() ),
     Symbol(SP), many( anyof( " \t\n" ) ) ),
    env( NIL_, 2,
         Symbol(name_part), Operator( NIL_, stringify ),
         Symbol(street_name), Operator( NIL_, stringify ) )
  );
  print_list( parsers ), puts("\n"); // long output when showing innards

  parser start = first( assoc_symbol( postal_address, parsers ) );
  print_list( start ), puts("\n");
  
  print_list( parse( start,
      chars_from_str( "Mr. luser droog I\n2357 Streetname\nAnytown, ST 00700\n" ) ) ),
    puts("");

  return  0;
}

Output from the testing code:

$ make clean test
rm *.o
cc -std=c99 -g -Wall -Wpedantic -Wextra -Wno-unused-function -Wno-unused-parameter -Wno-switch -Wno-return-type -Wunused-variable    -c -o pc11object.o pc11object.c
cc -std=c99 -g -Wall -Wpedantic -Wextra -Wno-unused-function -Wno-unused-parameter -Wno-switch -Wno-return-type -Wunused-variable    -c -o pc11parser.o pc11parser.c
cc -std=c99 -g -Wall -Wpedantic -Wextra -Wno-unused-function -Wno-unused-parameter -Wno-switch -Wno-return-type -Wunused-variable    -c -o pc11test.o pc11test.c
cc -std=c99 -g -Wall -Wpedantic -Wextra -Wno-unused-function -Wno-unused-parameter -Wno-switch -Wno-return-type -Wunused-variable  -o pc11 pc11object.o pc11parser.o pc11test.o 
./pc11
test_basics
...(chars_from_str) 
...(chars_from_str) 
('a' .('b' .('c' .('d' .('e' .('f' ....(force_chars_from_string) ))))))
('a' 'b' 'c' 'd' 'e' 'f' ...(force_chars_from_string) ) 
('a' .('b' .('c' .('d' .('e' .('f' .(EOF .() )))))))
('a' 'b' 'c' 'd' 'e' 'f' EOF ) 

test_parsers
(OK '*' ...(chars_from_str) ) 
(FAIL "Do you want a cookie?" ...(chars_from_str) ) 
(OK 'a' ...(force_chars_from_string) ) 
(OK 'a' ...(force_chars_from_string) ) 
(OK 'a' ...(force_chars_from_string) ) 

test_regex
Parser(satisfy, ((SATISFY_PRED .Oper(always_true, () ) ).() )) 
(OK 'a' ...(force_chars_from_string) ) 
(OK '.' ...(force_chars_from_string) ) 
(OK '\' ...(force_chars_from_string) ) 

Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '.' ) ).() )) 
(FAIL ("predicate not satisfied" Oper(is_literal, '.' ) ) 'a' ...(force_chars_from_string) ) 
(OK '.' ...(force_chars_from_string) ) 
(FAIL ("predicate not satisfied" Oper(is_literal, '.' ) ) '\' ...(force_chars_from_string) ) 

Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '\' ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(always_true, () ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) 
(FAIL ("predicate not satisfied" Oper(is_literal, '\' ) ) 'a' ...(force_chars_from_string) ) 
(FAIL ("predicate not satisfied" Oper(is_literal, '\' ) ) '.' ...(force_chars_from_string) ) 
(OK ('\' '.' ) ...(force_chars_from_string) ) 
(OK ('\' 'a' ) ...(force_chars_from_string) ) 

Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '\' ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '.' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) 
(FAIL ("predicate not satisfied" Oper(is_literal, '\' ) ) 'a' ...(force_chars_from_string) ) 
(FAIL ("predicate not satisfied" Oper(is_literal, '\' ) ) '.' ...(force_chars_from_string) ) 
(OK ('\' '.' ) ...(force_chars_from_string) ) 
(FAIL (("predicate not satisfied" Oper(is_literal, '.' ) ) "after" '\' ) 'a' ...(force_chars_from_string) ) 

Parser(either, ((EITHER_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '\' ) ).() )) ).((EITHER_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'a' ) ).() )) ).() ))) 
(OK 'a' ...(force_chars_from_string) ) 
(FAIL ("predicate not satisfied" Oper(is_literal, 'a' ) ) '.' ...(force_chars_from_string) ) 
(OK '\' ...(force_chars_from_string) ) 
(OK '\' ...(force_chars_from_string) ) 

Parser(satisfy, ((SATISFY_PRED .Oper(is_anyof, "abcd" ) ).() )) 
(OK 'a' ...(force_chars_from_string) ) 
(FAIL ("predicate not satisfied" Oper(is_anyof, "abcd" ) ) '.' ...(force_chars_from_string) ) 

test_ebnf
((postal_address Parser(sequence, ((SEQUENCE_P .Parser(bind) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(sequence) ).((SEQUENCE_Q .Parser(sequence) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (name_part Parser(either, ((EITHER_P .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(sequence) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '
' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((EITHER_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(bind) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).() ))) ) (personal_part Parser(either, ((EITHER_P .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '.' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((EITHER_Q .Parser(sequence) ).() ))) ) (street_address Parser(sequence, ((SEQUENCE_P .Parser(sequence) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(bind) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '
' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (zip_part Parser(sequence, ((SEQUENCE_P .Parser(sequence) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, ',' ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(sequence) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(sequence) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '
' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (opt_suffix_part Parser(either, ((EITHER_P .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'S' ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'r' ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '.' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((EITHER_Q .Parser(either, ((EITHER_P .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'J' ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'r' ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '.' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((EITHER_Q .Parser(either, ((EITHER_P .Parser(sequence) ).((EITHER_Q .Parser(succeeds, () ) ).() ))) ).() ))) ).() ))) ) (opt_apt_num Parser(either, ((EITHER_P .(Parser(sequence) .() )).((EITHER_Q .Parser(succeeds, () ) ).() ))) ) (apt_num Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (town_name Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_alpha, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (state_code Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_upper, () ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_upper, () ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (zip_code Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (initial Parser(either, ((EITHER_P .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'M' ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'r' ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 's' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((EITHER_Q .Parser(either, ((EITHER_P .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'M' ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'r' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((EITHER_Q .Parser(either, ((EITHER_P .Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'M' ) ).() )) ).((SEQUENCE_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 's' ) ).() )) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((EITHER_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'M' ) ).() )) ).() ))) ).() ))) ).() ))) ) (roman_numeral Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'I' ) ).() )) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(either, ((EITHER_P .(Parser(either, ((EITHER_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'V' ) ).() )) ).((EITHER_Q .Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, 'X' ) ).() )) ).() ))) .() )).((EITHER_Q .Parser(succeeds, () ) ).() ))) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (first_name Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_alpha, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (last_name Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_alpha, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (house_num Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (street_name Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_alpha, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (EPSILON Parser(succeeds, () ) ) (SP Parser(either) ) (NAME Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_alpha, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (NUMBER Parser(sequence, ((SEQUENCE_P .Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ).((SEQUENCE_Q .Parser(either) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ) (UPPER Parser(satisfy, ((SATISFY_PRED .Oper(is_upper, () ) ).() )) ) (DIGIT Parser(satisfy, ((SATISFY_PRED .Oper(is_digit, () ) ).() )) ) (EOL Parser(satisfy, ((SATISFY_PRED .Oper(is_literal, '
' ) ).() )) ) ) 

Parser(sequence, ((SEQUENCE_P .Parser(bind) ).((SEQUENCE_Q .Parser(sequence, ((SEQUENCE_P .Parser(sequence) ).((SEQUENCE_Q .Parser(sequence) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) ).((SEQUENCE_OP .Oper(concat, () ) ).() )))) 

(OK ("Mr. luser droog I
" '2' '3' '5' '7' ' ' "Streetname" '
' 'A' 'n' 'y' 't' 'o' 'w' 'n' ',' ' ' 'S' 'T' ' ' '0' '0' '7' '0' '0' '
' ) ...(force_chars_from_string) ) 
\$\endgroup\$
3
  • \$\begingroup\$ Where is the type list defined? \$\endgroup\$
    – pacmaninbw
    Jun 23 at 14:58
  • \$\begingroup\$ @pacmaninbw It's at the top of pc11object.h. All of the smorgasbord of types are "subclasses" of object but different ones are used to convey semantic information to the reader. So a list ought to be a pointer to a union object with the tag == LIST, but the C type system doesn't actually help enforce this, so it's a promise to the reader that the object should be a list object. \$\endgroup\$ Jun 23 at 15:37
  • \$\begingroup\$ I tried editing this info ^^ into the post, but I'm hitting the maximum post length limit. \$\endgroup\$ Jun 23 at 16:13

1 Answer 1

1
\$\begingroup\$

General Observations

The code is not maintainable. While the code seems to follow some general software development principles such as the Single Responsibility Principle there is no documentation (comments) within the code. Each file should indicate the purpose of the file and the design decisions within the file. The comments that do exist are not helpful, meaningful:

    print(ch), puts("");       // print with dot notation
    print_list(ch), puts("");  // print with list notation
    drop(6, ch);                 // force first 6 elements of stream

...
    print_list(parsers), puts("\n"); // long output when showing innards

Enum declarations such as

typedef enum {
    INVALID, INT, LIST, SUSPENSION, PARSER, OPERATOR, SYMBOL, STRING, VOID
} tag;

are harder to maintain than enums that are declared vertically. The code contains both so the code is inconsistent in its implementation.

The fact that pointers are used is hidden in many places:

#define IS_THE_TARGET_OF_THE_HIDDEN_POINTER_  *
typedef union    object  IS_THE_TARGET_OF_THE_HIDDEN_POINTER_  object;
typedef object   integer;
typedef object   list;
typedef object   suspension;
typedef object   parser;
typedef object   operator;
typedef operator binoperator;
typedef operator predicate;
typedef object   symbol;
typedef object   string;
typedef object   boolean;
typedef object   fSuspension(object env);
typedef object   fParser(object env, list input);
typedef object   fOperator(object env, object input);
typedef boolean  fPredicate(object env, object input);
typedef object   fBinOperator(object left, object right);

Hiding pointers can lead to all kinds of maintenance issues, and it makes the code harder to write and debug.

Most of the declarations above could use some comments, I don't know what parser should actually be doing, nor do I now what suspension is for. The list of typedefs above also needs some vertical spacing, I was originally unable to find list.

Missing Include Guards

Include guards are necessary to prevent header files from being included multiple times. The code doesn't contain any include guards in the header files. There are 2 ways in C and C++ to implement include guards, for personal preference I use

#ifndef INCLUDE_FILENAME_H
#define INCLUDE_FILENAME_H

Body of include here
...

#endif /* INCLUDE_FILENAME_H */

The alternative is #pragma once In the C and C++ programming languages, pragma once is a non-standard but widely supported preprocessor directive designed to cause the current source file to be included only once in a single compilation. Thus, #pragma once serves the same purpose as include guards, but with several advantages, including: less code, avoidance of name clashes, and sometimes improvement in compilation speed. On the other hand, #pragma once is not necessarily available in all compilers and its implementation is tricky and might not always be reliable.

\$\endgroup\$
3
  • \$\begingroup\$ In my defense, there is an include guard, but only one, and it's weird. I'm using the "McIllroy convention" where it goes around the #include ... directive instead of inside the header. In this sample, there's only one header that includes another, so it's hiding at the very top of pc11parser.h. But, that doesn't dull the force of your earlier observation that there should be more documentation. And the fact that's I'm using an unusual convention is definitely something to document. \$\endgroup\$ Jun 25 at 3:46
  • \$\begingroup\$ I did see that. You actually have 3 include files. \$\endgroup\$
    – pacmaninbw
    Jun 25 at 14:49
  • \$\begingroup\$ I was reluctant to accept this review at first because it hurt my pride in my beautiful code. But once I got started writing up some more detailed explanation, ... there sure is a whole of stuff to explain. Give me a few days (or weeks) to get this documentation is some kind of order, and I'll be back with (hopefully) something worth looking at. Thank you for your help. Edit: In the previous question, I linked to several usenet threads full of more detailed explanation of the whole concept and the basic parts. Maybe I don't need quite that level of detail, but the combined scope of it.... \$\endgroup\$ Jun 27 at 3:34

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.