8
\$\begingroup\$

Parser Combinators are the amazingly elegant way to write parsers that has evolved over on the functional programming side of the world, but have been less available or accessible for imperative languages. I have attempted somewhat to bridge this gap by stealing copying as many ideas from FP as were needed to make these combinators in C.

I've written an overview of Parser Combinators and presentations of the basic lisp-like object system and the higher order functions which supplement the basic objects. Of course wikipedia has a nice article on the topic, and my code mostly follows the excellent paper by Hutton and Meijer which is also a good introduction.

This code is the result of 16 (or so) re-writes of the code in my previous question. I anticipate at least one more re-write to add more features like checking the offside rule both for parsing syntaxes lke Python which use this rule, or just checking that indentation in C code is reasonable.

A few remarks about the code overall: I'm trying the "McIllroy convention" which places header guards around the #include lines rather than inside the included files. The object type is a pointer to a union. Most of the .c files have a (name-mangled) main() function which does some simple tests; somewhere along the continuum between real unit testing and not testing.

I'm looking for review of the "weird stuff" if possible. Particularly the handling of suspensions, which represent values to be lazily evaluated. But of course anything weird or suspicious is fair game.

ppnarg.h
Written by Laurent Deniau for the C Object System. I have extended the maximum number of arguments a little.

/*
 * 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

pc9obj.h
Public interface to the basic objects. All the constructors for various types of objects and lists. Especially, chars_from_string which produces a lazy list of characters. The symbol-typed objects are constructed with a unique numeric identifer and a print string. These unique ids are generated by declaring the names in an enum. The odd name SYM1 is used to start the next enum in the next layer to add more symbols keeping all ids unique.

#define PC9OBJ_H
#include <stdlib.h>
#include <stdio.h>
#define POINTER_TO  *
typedef union uobject  POINTER_TO object;
typedef object list;
typedef object parser;
typedef object oper;
typedef oper   predicate;
typedef object boolean;
typedef object fSuspension( object );
typedef list fParser( object, list );
typedef object fOperator( object, object );
typedef boolean fPredicate( object, object );
typedef object fBinOper( object, object );

enum object_symbols {
  T, F, X, A, B,
  SYM1
};
object T_, NIL_;

int valid( object a );
object Int( int i );
list one( object a );
list cons( object a, object b );
object Suspension( object v, fSuspension *f );
parser Parser( object v, fParser *f );
oper Operator( object v, fOperator *f );
object String( char *s, int disposable );
object Symbol_( int sym, char *pname );
#define Symbol(n) Symbol_( n, #n )
object Void( void *v );

void add_global_root( object a );
int garbage_collect( object local_roots );

object x_( list a );
object xs_( list a );
list take( int n, list o );
list drop( int n, list o );

list chars_from_string( char *v );
list chars_from_file( FILE *v );
object string_from_chars( list o );

void print( object o );
void print_list( list a );
void print_flat( list a );
void print_data( list a );
#define PRINT_WRAPPER(_, __, ___) printf( "%s: %s %s= ", __func__, #__, ___ ), _( __ ), puts("")
#define PRINT(__)      PRINT_WRAPPER( print_list, __, "" )
#define PRINT_FLAT(__) PRINT_WRAPPER( print_flat, __, "flat" )
#define PRINT_DATA(__) PRINT_WRAPPER( print_data, __, "data" )

pc9objpriv.h
Private interface to the basic objects. Objects are represented as a pointer to a tagged union. The at_ function forces execution of suspensions, but externally this action must be performed by calling take or drop.

#define PC9OBJPRIV_H
#ifndef PC9OBJ_H
  #include "pc9obj.h"
#endif
typedef enum object_tag {
  INVALID, INTEGER, LIST, SUSPENSION, PARSER, OPERATOR, SYMBOL, STRING, VOID,
} tag;
union uobject { tag t;
       struct { tag t; int i;                                } Int;
       struct { tag t; object a, b;                          } List;
       struct { tag t; object v; fSuspension *f;             } Suspension;
       struct { tag t; object v; fParser *f;                 } Parser;
       struct { tag t; object v; fOperator *f;               } Operator;
       struct { tag t; int symbol; char *pname; object data; } Symbol;
       struct { tag t; char *string; int disposable;         } String;
       struct { tag t; object next;                          } Header;
       struct { tag t; void *v;                              } Void;
};
object new_( object a );
#define OBJECT(...) new_( (union uobject[]){{ __VA_ARGS__ }} )
object at_( object a );

object fill_string( char **s, list o );
int obj_main( void );

pc9obj.c
Implementation of basic objects. Objects are allocated as two structs side by side with the hidden left object used as an allocation record. The allocation records form a singly linked list which is traversed during a sweep of the garbage collector. x_ and xs_ are the famous lisp car and cdr functions, but I like the haskell naming convention so I used those; but x is too useful as a local variable name so they got underscores appended.

#include <stdio.h>
#include "pc9objpriv.h"

static void mark_objects( list a );
static int sweep_objects( list *po );

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

static list global_roots = NULL;
static list allocation_list = NULL;

object
new_( object a ){
  object p = calloc( 2, sizeof *p );
  return  p  ? p[0] = (union uobject){ .Header = { 0, allocation_list } },
               allocation_list = p,
               p[1] = *a,
               &p[1]
             : 0;
}

int
valid( object a ){
  switch( a  ? a->t  : 0 ){
  default:
    return 0;
  case INTEGER:
  case LIST:
  case SUSPENSION:
  case PARSER:
  case OPERATOR:
  case SYMBOL:
  case STRING:
    return 1;
  }
}

object
Int( int i ){
  return  OBJECT( .Int = { INTEGER, i } );
}

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

list
cons( object a, object b ){
  return  OBJECT( .List = { LIST, a, b } );
}

object
Suspension( object v, fSuspension *f ){
  return  OBJECT( .Suspension = { SUSPENSION, v, f } );
}

parser
Parser( object v, fParser *f ){
  return  OBJECT( .Parser = { PARSER, v, f } );
}

oper
Operator( object v, fOperator *f ){
  return  OBJECT( .Operator = { OPERATOR, v, f } );
}

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

object
Symbol_( int sym, char *pname ){
  return  OBJECT( .Symbol = { SYMBOL, sym, pname } );
}

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

void
add_global_root( object a ){
  global_roots = cons( a, global_roots );
}

int
garbage_collect( object local_roots ){
  mark_objects( local_roots );
  mark_objects( global_roots );
  return  sweep_objects( &allocation_list );
}

static tag *
mark( object a ){
  return  &a[-1].Header.t;
}

static void
mark_objects( list a ){
  if(  !valid(a) || *mark( a )  ) return;
  *mark( a ) = 1;
  switch(  a->t  ){
  case LIST:       mark_objects( a->List.a ); 
                   mark_objects( a->List.b );       break;
  case PARSER:     mark_objects( a->Parser.v );     break;
  case OPERATOR:   mark_objects( a->Operator.v );   break;
  case SYMBOL:     mark_objects( a->Symbol.data );  break;
  case SUSPENSION: mark_objects( a->Suspension.v ); break;
  }
}

static int
sweep_objects( list *po ){
  int count = 0;
  while(  *po  )
    if(  (*po)->t  ){
      (*po)->t = 0;
      po = &(*po)->Header.next;
    } else {
      object z = *po;
      *po = (*po)->Header.next;
      if(  z[1].t == STRING && z[1].String.disposable  )
        free( z[1].String.string );
      free( z );
      ++count;
    }
  return  count;
}



object
at_( object a ){
  return  valid( a ) && a->t == SUSPENSION  ? at_( a->Suspension.f( a->Suspension.v ) )  : a;
}


object
px_( object v ){
  list a = v;
  *a = *at_( a );
  return  x_( a );
}
object
x_( list a ){
  return  valid( a )  ?
              a->t == LIST        ? a->List.a             :
              a->t == SUSPENSION  ? Suspension( a, px_ )  : NIL_
          : NIL_;
}

object
pxs_( object v ){
  list a = v;
  *a = *at_( a );
  return  xs_( a );
}
object
xs_( list a ){
  return  valid( a )  ?
              a->t == LIST        ? a->List.b              :
              a->t == SUSPENSION  ? Suspension( a, pxs_ )  : NIL_
          : NIL_;
}

list
take( int n, list o ){
  if(  n == 0  ) return NIL_;
  *o = *at_( o );
  return  valid( o )  ? cons( x_( o ), take( n-1, xs_( o ) ) )  : NIL_;
}
list
drop( int n, list o ){
  if(  n == 0  ) return o;
  *o = *at_( o );
  return  valid( o )  ? drop( n-1, xs_( o ) )  : NIL_;
}


list
pchars_from_string( object v ){
  char *p = v->String.string;
  return  *p  ?  cons( Int( *p ), Suspension( String( p+1, 0 ), pchars_from_string ) )  : Symbol(EOF);
}
list
chars_from_string( char *p ){
  return  p  ?  Suspension( String( p, 0 ), pchars_from_string )  : NIL_;
}


list
pchars_from_file( object v ){
  FILE *f = v->Void.v;
  int c = fgetc( f );
  return  c != EOF  ? cons( Int( c ), Suspension( v, pchars_from_file ) )  : Symbol(EOF);
}
list
chars_from_file( FILE *f ){
  return  f  ? Suspension( Void( f ), pchars_from_file ) : NIL_;
}


static int
count_ints( list o ){
  return  !o               ? 0 :
          o->t == SUSPENSION ? *o = *at_( o ), count_ints( o ) :
          o->t == INTEGER  ? 1 :
          o->t == LIST     ? count_ints( o->List.a ) + count_ints( o->List.b ) :
          0;
}

object
fill_string( char **s, list o ){
  return  !o    ? NULL :
          o->t == INTEGER  ? *(*s)++ = o->Int.i, NULL :
          o->t == LIST     ? fill_string( s, o->List.a ), fill_string( s, o->List.b ) :
          NULL;
}

object
string_from_chars( list o ){
  char *s = calloc( count_ints( o ) + 1, 1 );
  object z = String( s, 1 );
  return  fill_string( &s, o ), z;
}

void
print( object o ){
  if(  !o  ){ printf( "() " ); return; }
  switch( o->t ){
  case INTEGER:    printf( "%d ", o->Int.i );            break;
  case LIST:       printf( "(" );
                     print( o->List.a );
                     print( o->List.b );
                   printf( ") " );                       break;
  case SUSPENSION: printf( "... " );              break;
  case PARSER:     printf( "Parser " );                  break;
  case OPERATOR:   printf( "Oper " );                break;
  case STRING:     printf( "\"%s\"", o->String.string ); break;
  case SYMBOL:     printf( "%s ", o->Symbol.pname );     break;
  case INVALID:    printf( "_ " );                       break;
  default:         printf( "INVALID " );                 break;
  }
}

void
print_listn( list a ){
  switch(  a  ? a->t  : 0  ){
  default: print( a ); return;
  case LIST: print_list( x_( a ) ), print_listn( xs_( a ) ); return;
  }
}

void
print_list( list a ){
  switch(  a  ? a->t  : 0  ){
  default: print( a ); return;
  case LIST: printf( "(" ), print_list( x_( a ) ), print_listn( xs_( a ) ), printf( ")" ); return;
  }
}

void
print_flat( list a ){
  if(  !a  ) return;
  if(  a->t != LIST  ){ print( a ); return; }
  print_flat( a->List.a );
  print_flat( a->List.b );
}

void
print_data( list a ){
  if(  !a  ) return;
  switch(  a->t  ){
  case LIST:  print_data( a->List.a), print_data( a->List.b );  break;
  case STRING: printf( "%s", a->String.string ); break;
  case SYMBOL: print_data( a->Symbol.data );  break;
  }
}


int
test_basics(){
  list ch = chars_from_string( "abcdef" );
  PRINT( ch );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 1, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( x_( ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( x_( xs_( ch ) ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 1, x_( xs_( ch ) ) ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 5, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( ch );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 6, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 1, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 2, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 2, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 2, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  PRINT( take( 2, ch ) );
  PRINT( Int( garbage_collect( ch ) ) );
  return 0;
}

int obj_main(){ return test_basics(); }

pc9fp.h
Interface to the "functional programming" functions. These have all been tweaked to deal nicely (?) with suspensions and force only enough execution to make progress on a computation.

#define PC9FP_H
#ifndef PC9OBJ_H
  #include "pc9obj.h"
#endif

boolean eq( object a, object b );

list env( list tail, int n, ... );
object assoc( object a, list b );

list copy( list a );
list append( list a, list b );

object apply( oper f, object o );
list map( oper f, list o );
list join( list o );

object collapse( fBinOper *f, list o );
object reduce( fBinOper *f, int n, object *po );

pc9fp.c
Implementation of the "functional programming" functions.

#include <stdarg.h>
#include <string.h>
#include "pc9fp.h"
#include "pc9objpriv.h"

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

list
copy( list a ){
  return  !valid( a )   ? NIL_                                       :
          a->t == LIST  ? cons( copy( x_( a ) ), copy( xs_( a ) ) )  :
                      a;
}

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 a, list b ){
  return  !valid( b )                      ? NIL_            :
          valid( eq( a, x_( x_( b ) ) ) )  ? xs_( x_( b ) )  :
                                             assoc( a, xs_( b ) );
}

static list
pappend( object v ){
  list a = assoc( Symbol(A), v );
  list b = assoc( Symbol(B), v );
  *a = *at_( a );
  return  append( a, b );
}
list
append( list a, list b ){
  return  !valid( a )         ? b                                                               :
          a->t == SUSPENSION  ? Suspension( env( 0, 2, Symbol(A), a, Symbol(B), b ), pappend )  :
                                cons( x_( a ), append( xs_( a ), b ) );
}


static object
papply( object v ){
  oper f = assoc( Symbol(F), v );
  object o = assoc( Symbol(X), v );
  *o = *at_( o );
  return  valid( o )  ? f->Operator.f( f->Operator.v, o )  : NIL_;
}
object
apply( oper f, object o ){
  return  f->t == OPERATOR  ? 
              valid( o )  ?
                  o->t == SUSPENSION  ? Suspension( env( 0, 2, Symbol(F), f, Symbol(X), o ), papply )
                        : f->Operator.f( f->Operator.v, o )
                  : f->Operator.f( f->Operator.v, o )    // for using( maybe(), ... )
              : NIL_;
  //return  f->t == OPERATOR  ? f->Operator.f( f->Operator.v, o )  : NIL_;
}


static list
pmap( object v ){
  oper f = assoc( Symbol(F), v );
  list o = assoc( Symbol(X), v );
  *o = *at_( o );
  return  valid( o )  ? cons( apply( f, x_( o ) ), map( f, xs_( o ) ) ) : NIL_;
}
list
map( oper f, list o ){
  return  valid( o )  ?
              o->t == SUSPENSION  ? Suspension( env( 0, 2, Symbol(F), f, Symbol(X), o ), pmap ) :
              cons( apply( f, x_( o ) ),
                    Suspension( env( 0, 2, Symbol(F), f, Symbol(X), xs_( o ) ), pmap ) )
                      : NIL_;
  //return  valid( o )  ? cons( apply( f, x_( o ) ), map( f, xs_( o ) ) )  : NIL_;
}


static list
pjoin( object v ){
  list o = assoc( Symbol(X), v );
  *o = *at_( o );
  return  append( x_( take( 1, o ) ), join( xs_( o ) ) );
}
list
join( list o ){
  return  valid( o )  ? 
              o->t == SUSPENSION  ? Suspension( env( 0, 1, Symbol(X), o ), pjoin )  :
                  append( x_( o ), Suspension( env( 0, 1, Symbol(X), xs_( o ) ), pjoin ) )
                      : NIL_;
  //return  valid( o )  ? append( x_( o ), join( xs_( o ) ) )  : NIL_;
}

static object
do_collapse( fBinOper *f, object a, object b ){
  return  valid( b )  ? f( a, b )  : a;
}

object
collapse( fBinOper *f, list o ){
  return  valid( o )  ?
              o->t == LIST  ? do_collapse( f, collapse( f, x_( o ) ), collapse( f, xs_( o ) ) )
                            : o
                      : NIL_;
}

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

pc9par.h
Interface to the Parser Combinators. Constructing parsers for single characters alpha digit sat or combining parsers together seq plus. Construct a parser using a regex.

#define PC9PAR_H
#ifndef PC9FP_H
  #include "pc9fp.h"
#endif
#include "ppnarg.h"

enum parser_symbols {
  VALUE = SYM1, PRED, P, PP, NN, Q, R, FF, XX, AA, ID, USE, ATOM,
  SYM2
};

list parse( parser p, list input );

parser result( object a );
parser zero( void );
parser item( void );

parser bind( parser p, oper f );

parser plus( parser p, parser q );
#define PLUS(...)  reduce( plus, PP_NARG(__VA_ARGS__), (object[]){ __VA_ARGS__ } )

parser sat( predicate pred );
parser alpha( void );
parser digit( void );
parser lit( object a );
parser chr( int c );
parser str( char *s );
parser anyof( char *s );
parser noneof( char *s );

parser seq( parser p, parser q );
#define SEQ(...)  reduce( seq, PP_NARG(__VA_ARGS__), (object[]){ __VA_ARGS__ } )
parser xthen( parser p, parser q );
parser thenx( parser p, parser q );
parser into( parser p, object id, parser q );

parser maybe( parser p );
parser forward( void );
parser many( parser p );
parser some( parser p );

parser trim( parser p );
parser using( parser p, fOperator *f );

parser regex( char *re );

int par_main( void );

pc9par.c
Implementation of the Parser Combinators. Includes 3 "internal DSL" examples with the regex() function, and pprintf() and pscanf() functions.

#include <ctype.h>
#include <stdarg.h>
#include <string.h>
#include "pc9par.h"
#include "pc9objpriv.h"


list
parse( parser p, list input ){
  return  valid( p ) && p->t == PARSER && valid( input ) ? p->Parser.f( p->Parser.v, input )  : NIL_;
}


static list
presult( object v, list input ){
  return  one( cons( assoc( Symbol(VALUE), v ), input ) );
}
parser
result( object a ){
  return  Parser( env( 0, 1, Symbol(VALUE), a ), presult );
}

static list
pzero( object v, list input ){
  return  NIL_;
}
parser
zero( void ){
  return  Parser( 0, pzero );
}

static list
pitem( object v, list input ){
  drop( 1, input );
  return  valid( input ) ? one( cons( x_( input ), xs_( input ) ) ) : NIL_;
  //return  valid( input ) ? one( cons( x_( take( 1, input ) ), xs_( input ) ) )  : NIL_;  //strict
  //return  valid( input ) ? one( cons( x_( input ), xs_( input ) ) )  : NIL_;             //lazy
}
parser
item( void ){
  return  Parser( 0, pitem );
}

static list
pbind( object v, list input ){
  parser p = assoc( Symbol(P), v );
  oper f = assoc( Symbol(FF), v );
  list r = parse( p, input );
  return  valid( r )  ? join( map( Operator( valid( f->Operator.v ) ?
                                               append( copy( f->Operator.v ), v )  : v,
                                             f->Operator.f ),
                                   r ) )
                      : NIL_;
}
parser
bind( parser p, oper f ){
  return  Parser( env( 0, 2, Symbol(P), p, Symbol(FF), f ), pbind );
}

static list
bplus( object v ){
  list r = assoc( Symbol(R), v );
  object qq = assoc( Symbol(Q), v );
  *r = *at_( r );
  return  valid( r )  ? append( r, qq ) : qq;
}
static list
cplus( object v ){
  parser q = assoc( Symbol(Q), v );
  list input = assoc( Symbol(X), v );
  return  parse( q, input );
}
static list
pplus( object v, list input ){
  parser p = assoc( Symbol(P), v );
  parser q = assoc( Symbol(Q), v );
  list r = parse( p, input );
  object qq = Suspension( env( 0, 2, Symbol(Q), q, Symbol(X), input ), cplus );
  return  valid( r )  ? 
              r->t == SUSPENSION  ? Suspension( env( 0, 2, Symbol(R), r, Symbol(Q), qq ), bplus )
                                  : append( r, qq )
                      : qq;
}
parser
plus( parser p, parser q ){
  if(  !q  ) return  p;
  return  Parser( env( 0, 2, Symbol(P), p, Symbol(Q), q ), pplus );
}

static list
psat( object v, list input ){
  predicate pred = assoc( Symbol(PRED), v );
  object r = apply( pred, x_( input ) );
  return  valid( r )  ? one( cons( x_( input ), xs_( input ) ) )  : NIL_;
}
parser
sat( predicate pred ){
  return  bind( item(), Operator( env( 0, 1, Symbol(PRED), pred ), psat ) );
}

static boolean
palpha( object v, object o ){
  return  isalpha( o->Int.i )  ? T_  : NIL_;
}
parser
alpha( void ){
  return  sat( Operator( 0, palpha ) );
}

static boolean
pdigit( object v, object o ){
  return  isdigit( o->Int.i )  ? T_  : NIL_;
}
parser
digit( void ){
  return  sat( Operator( 0, pdigit ) );
}

static boolean
plit( object v, object o ){
  object a = assoc( Symbol(X), v );
  return  eq( a, o );
}
parser
lit( object a ){
  return  sat( Operator( env( 0, 1, Symbol(X), a ), plit ) );
}

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

parser
str( char *s ){
  return  *s  ? seq( chr( *s ), str( s+1 ) )  : result(0);
}

parser
anyof( char *s ){
  return  *s  ? plus( chr( *s ), anyof( s+1 ) )  : zero();
}

static list
pnone( object v, list input ){
  parser p = assoc( Symbol(NN), v );
  object r = parse( p, input );
  *r = *at_( r );
  return  valid( r )  ? NIL_  : pitem( 0, input );
}
parser
noneof( char *s ){
  return  Parser( env( 0, 1, Symbol(NN), anyof( s ) ), pnone );
}


static list
pprepend( object v, list o ){
  object a = assoc( Symbol(AA), v );
  return  valid( a )  ? cons( cons( a, x_( o ) ), xs_( o ) )  : o;
}
static list
prepend( list a, list b ){
  return  map( Operator( env( 0, 1, Symbol(AA), a ), pprepend ), b );
}
static list
pseq( object v, list output ){
  parser q = assoc( Symbol(Q), v );
  return  prepend( x_( output ), parse( q, xs_( output ) ) );
}
parser
seq( parser p, parser q ){
  if(  !q  ) return  p;
  return  bind( p, Operator( env( 0, 1, Symbol(Q), q ), pseq ) );
}

static list
pxthen( object v, list o ){
  return  one( cons( xs_( x_( o ) ), xs_( o ) ) );
}
parser
xthen( parser p, parser q ){
  return  bind( seq( p, q ), Operator( 0, pxthen ) );
}

static list
pthenx( object v, list o ){
  return  one( cons( x_( x_( o ) ), xs_( o ) ) );
}
parser
thenx( parser p, parser q ){
  return  bind( seq( p, q ), Operator( 0, pthenx ) );
}

static list
pinto( object v, list o ){
  object id = assoc( Symbol(ID), v );
  parser q = assoc( Symbol(Q), v );
  return  parse( Parser( env( q->Parser.v, 1, id, x_( o ) ), q->Parser.f ), xs_( o ) );
}
parser
into( parser p, object id, parser q ){
  return  bind( p, Operator( env( 0, 2, Symbol(ID), id, Symbol(Q), q ), pinto ) );
}


parser
maybe( parser p ){
  return  plus( p, result(0) );
}

parser
forward( void ){
  return  Parser( 0, 0 );
}

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

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

static list
ptrim( object v, list input ){
  parser p = assoc( Symbol(PP), v );
  list r = parse( p, input );
  return  valid( r )  ? one( x_( take( 1, r ) ) )  : r;
}
parser
trim( parser p ){
  return  Parser( env( 0, 1, Symbol(PP), p ), ptrim );
}


static list
pusing( object v, list o ){
  oper f = assoc( Symbol(USE), v );
  return  one( cons( apply( f, x_( o ) ), xs_( o ) ) );
}
parser
using( parser p, fOperator *f ){
  return  bind( p, Operator( env( 0, 1, Symbol(USE), Operator( 0, f ) ), pusing ) );
}


static parser
do_meta( parser a, object o ){
  switch( o->Int.i ){
  case '*':  return  many( a ); break;
  case '+':  return  some( a ); break;
  case '?':  return  maybe( a ); break;
  } return  a;
}
static parser
on_meta( object v, object o ){
  parser atom = assoc( Symbol(ATOM), v );
  return  valid( o ) ? do_meta( atom, o )  : atom;
}
static parser  on_dot( object v, object o ){ return  item(); }
static parser  on_chr( object v, object o ){ return  lit( o ); }
static parser  on_term( object v, object o ){ return  collapse( seq, o ); }
static parser  on_expr( object v, object o ){ return  collapse( plus, o ); }

#define META     "*+?"
#define SPECIAL  META ".|()"
parser
regex( char *re ){
  static parser p;
  if(  !p  ){
    parser dot   = using( chr('.'), on_dot );
    parser meta  = anyof( META );
    parser escape = xthen( chr('\\'), anyof( SPECIAL "\\" ) );
    parser chr_  = using( plus( escape,  noneof( SPECIAL ) ), on_chr );
    parser expr_ = forward();
    parser atom  = PLUS( dot,
                         xthen( chr('('), thenx( expr_, chr(')') ) ),
                         chr_ );
    parser factor = into( atom, Symbol(ATOM), using( maybe( meta ), on_meta ) );
    parser term   = using( some( factor ), on_term );
    parser expr   = using( seq( term, many( xthen( chr('|'), term ) ) ), on_expr );
    *expr_ = *expr;
    p = trim( expr );
    add_global_root( p );
  }
  list r = parse( p, chars_from_string( re ) );
  return  valid( r )  ? ( x_( x_( r ) ) )  : r;
}

parser
vusing( parser p, object v, fOperator *f ){
  return  bind( p, Operator( env( 0, 1, Symbol(USE), Operator( v, f ) ), pusing ) );
}

object sum( object a, object b ){ return  Int( a->Int.i + b->Int.i ); }

boolean nz( object v, object o ){ return  o->Int.i ? T_ : NIL_; }


static object p_char( object v, list o ){
  va_list *p = (void *)v; return  putchar(va_arg( *p, int )), Int(1);
}
static object p_string( object v, list o ){
  va_list *p = (void *)v;
  char *s = va_arg( *p, char* );
  return  fputs( s, stdout ), Int(strlen( s ));
}
static object p_lit( object v, list o ){
  return  putchar( o->Int.i ), Int(1);
}

static object on_fmt( object v, list o ){ return  collapse( sum, o ); }

int
pprintf( char const *fmt, ... ){
  if(  !fmt  ) return  0;
  static va_list v;
  va_start( v, fmt );
  static parser p;
  if(  !p  ){
    parser directive = PLUS( using( chr('%'), p_lit ),
                             vusing( chr('c'), (void *)&v, p_char ),
                             vusing( chr('s'), (void *)&v, p_string ) );
    parser term = PLUS( xthen( chr('%'), directive ),
                        using( sat( Operator( 0, nz ) ), p_lit ) );
    parser format = many( term );
    p = using( format, on_fmt );
    add_global_root( p );
  }
  object r = parse( p, chars_from_string( (char*)fmt ) );
  drop( 1, r );
  va_end( v );
  return  x_( x_( r ) )->Int.i;
}


static object  convert_char( object v, list o ){
  va_list *p = (void *)v;
  char *cp = va_arg( *p, char* );
  *cp = o->Int.i;
  return  Int(1);
}
static object  convert_string( object v, list o ){
  va_list *p = (void *)v;
  char *sp = va_arg( *p, char* );
  fill_string( &sp, o );
  return  Int(1);
}

static parser  on_char( object v, list o ){
  return  vusing( item(), v, convert_char );
}
static parser  on_string( object v, list o ){
  return  vusing( xthen( many( anyof( " \t\n" ) ),  many( noneof( " \t\n" ) ) ), v, convert_string );
}

static object  r_zero( object v, list o ){ return  Int(0); }
static parser  pass( parser p ){ return  using( p, r_zero ); }

static parser  on_space( object v, list o ){ return  valid( o )  ? pass( many( anyof( " \t\n" ) ) )  : o; }
static parser  on_percent( object v, list o ){ return  pass( chr('%') ); }
static parser  on_lit( object v, list o ){ return  pass( lit( o ) ); }

static object  sum_up( object v, list o ){ return  collapse( sum, o ); }

static parser  on_terms( object v, list o ){ return  using( collapse( seq, o ), sum_up ); }

int
pscanf( char const *fmt, ... ){
  if(  !fmt  ) return  0;
  static va_list v;
  va_start( v, fmt );
  static parser p;
  if(  !p  ){
    parser space = using( many( anyof( " \t\n" ) ), on_space );
    parser directive = PLUS( using( chr('%'), on_percent ),
                             vusing( chr('c'), (void *)&v, on_char ),
                             vusing( chr('s'), (void *)&v, on_string ) );
    parser term  = PLUS( xthen( chr('%'), directive ),
                         using( sat( Operator( 0, nz ) ), on_lit ) );
    parser format = many( seq( space, term ) );
    p = using( format, on_terms );
    add_global_root( p );
  }
  list fp = parse( p, chars_from_string( (char*)fmt ) );
  drop( 1, fp );
  parser f = x_( x_( fp ) );
  if(  !valid( f )  ) return 0;
  list r = parse( f, chars_from_file( stdin ) );
  drop( 1, r );
  va_end( v );
  return  valid( r ) ? x_( x_( r ) )->Int.i : 0;
}


int test_pscanf(){
  char c;
  PRINT( Int( pscanf( "" ) ) );
  PRINT( Int( pscanf( "abc" ) ) );
  PRINT( Int( pscanf( "  %c", &c ) ) );
  PRINT( string_from_chars( Int( c ) ) );
  char buf[100];
  PRINT( Int( pscanf( "%s", buf ) ) );
  PRINT( String( buf, 0 ) );
  return 0;
}

int test_pprintf(){
  PRINT( Int( pprintf( "%% abc %c %s\n", 'x', "123" ) ) );
  return  0;
}


int test_regex(){
  parser a;
  PRINT( a = regex( "\\." ) );
  PRINT( parse( a, chars_from_string( "a" ) ) );
  PRINT( parse( a, chars_from_string( "." ) ) );
  PRINT( parse( a, chars_from_string( "\\." ) ) );
  parser b;
  PRINT( b = regex( "\\\\\\." ) );
  PRINT( parse( b, chars_from_string( "\\." ) ) );
  PRINT( take( 3, parse( b, chars_from_string( "\\." ) ) ) );
  parser r;
  PRINT( r = regex( "a?b+(c).|def" ) );
  PRINT( parse( r, chars_from_string( "abc" ) ) );
  PRINT( parse( r, chars_from_string( "abbcc" ) ) );
  PRINT( Int( garbage_collect( r ) ) );
  list s;
  PRINT( s = parse( r, chars_from_string( "def" ) ) );
  PRINT( take( 3, s ) );
  PRINT( parse( r, chars_from_string( "deff" ) ) );
  PRINT( parse( r, chars_from_string( "adef" ) ) );
  PRINT( parse( r, chars_from_string( "bcdef" ) ) );
  PRINT( Int( garbage_collect( cons( r, s ) ) ) );
  parser t;
  PRINT( t = regex( "ac|bd" ) );
  PRINT( parse( t, chars_from_string( "ac" ) ) );
  PRINT( take( 1, parse( t, chars_from_string( "bd" ) ) ) );
  PRINT( Int( garbage_collect( t ) ) );
  parser u;
  PRINT( u = regex( "ab|cd|ef" ) );
  PRINT( parse( u, chars_from_string( "ab" ) ) );
  PRINT( parse( u, chars_from_string( "cd" ) ) );
  PRINT( take( 1, parse( u, chars_from_string( "cd" ) ) ) );
  PRINT( parse( u, chars_from_string( "ef" ) ) );
  PRINT( take( 1, parse( u, chars_from_string( "ef" ) ) ) );
  PRINT( Int( garbage_collect( u ) ) );
  parser v;
  PRINT( v = regex( "ab+(c).|def" ) );
  PRINT( parse( v, chars_from_string( "def" ) ) );
  PRINT( take( 2, parse( v, chars_from_string( "def" ) ) ) );
  parser w;
  PRINT( w = regex( "a?b|c" ) );
  PRINT( parse( w, chars_from_string( "a" ) ) );
  PRINT( parse( w, chars_from_string( "b" ) ) );
  PRINT( take( 3, parse( w, chars_from_string( "c" ) ) ) );
  PRINT( Int( garbage_collect( w ) ) );
  return 0;
}


int test_env(){
  object e = env( 0, 2, Symbol(F), Int(2), Symbol(X), Int(4) );
  PRINT( e );
  PRINT( assoc( Symbol(F), e ) );
  PRINT( assoc( Symbol(X), e ) );
  return 0;
}

object b( object v, object o ){
  return  one( cons( Int( - x_( o )->Int.i ), xs_( o ) ) );
}

int test_parsers(){
  list ch = chars_from_string( "a b c 1 2 3 d e f 4 5 6" );
  {
    parser p = result( Int(42) );
    PRINT( parse( p, ch ) );
    PRINT( Int( garbage_collect( ch ) ) );
  }
  {
    parser q = zero();
    PRINT( parse( q, ch ) );
    PRINT( Int( garbage_collect( ch ) ) );
  }
  {
    parser r = item();
    PRINT( r );
    PRINT( parse( r, ch ) );
    PRINT( x_( parse( r, ch ) ) );
    PRINT( take( 1, x_( parse( r, ch ) ) ) );
    PRINT( x_( take( 1, x_( parse( r, ch ) ) ) ) );
    PRINT( take( 1, x_( take( 1, x_( parse( r, ch ) ) ) ) ) );
    PRINT( parse( bind( r, Operator( 0, b ) ), ch ) );
    PRINT( Int( garbage_collect( cons( ch, r ) ) ) );
  }
  {
    parser s = plus( item(), alpha() );
    PRINT( s );
    PRINT( parse( s, ch ) );
    PRINT( take( 2, parse( s, ch ) ) );
    PRINT( Int( garbage_collect( ch ) ) );
  }
  {
    parser t = lit( Int( 'a' ) );
    PRINT( parse( t, ch ) );
    parser u = str( "a b c" );
    PRINT( parse( u, ch ) );
    PRINT( Int( garbage_collect( cons( ch, cons( t, u ) ) ) ) );
  }
  return 0;
}

int par_main(){
  return 
      obj_main(),
      test_env(), test_parsers(),
      test_regex(),
          test_pprintf(),
          test_pscanf(),
          0;
}

pc9tok.h
Interface to the example tokenizer for circa 1975 pre-K&R C. Perhaps too much macro stuff? All the keywords and operators and punctuation which can be matched as exact strings are defined in an X-macro table which associates each string with an identifier. The identifiers are all defined in the enum for use with the symbol typed objects.

#define PC9TOK_H
#ifndef PC9PAR_H
  #include "pc9par.h"
#endif

#define Each_Symbolic(_) \
  _("int", k_int) _("char", k_char) _("float", k_float) _("double", k_double) _("struct", k_struct) \
  _("auto", k_auto) _("extern", k_extern) _("register", k_register) _("static", k_static) \
  _("goto", k_goto) _("return", k_return) _("sizeof", k_sizeof) \
  _("break", k_break) _("continue", k_continue) \
  _("if", k_if) _("else", k_else) \
  _("for", k_for) _("do", k_do) _("while", k_while) \
  _("switch", k_switch) _("case", k_case) _("default", k_default) \
  /*_("entry", k_entry)*/ \
  _("*", o_star) _("++", o_plusplus) _("+", o_plus) _(".", o_dot) \
  _("->", o_arrow) _("--", o_minusminus) _("-", o_minus) _("!=", o_ne) _("!", o_bang) _("~", o_tilde) \
  _("&&", o_ampamp) _("&", o_amp) _("==", o_equalequal) _("=", o_equal) \
  _("^", o_caret) _("||", o_pipepipe) _("|", o_pipe) \
  _("/", o_slant) _("%", o_percent) \
  _("<<", o_ltlt) _("<=", o_le) _("<", o_lt) _(">>", o_gtgt) _(">=", o_ge) _(">", o_gt) \
  _("=+", o_eplus) _("=-", o_eminus) _("=*", o_estar) _("=/", o_eslant) _("=%", o_epercent) \
  _("=>>", o_egtgt) _("=<<", o_eltlt) _("=&", o_eamp) _("=^", o_ecaret) _("=|", o_epipe) \
  _("(", lparen) _(")", rparen) _(",", comma) _(";", semi) _(":", colon) _("?", quest) \
  _("{", lbrace) _("}", rbrace) _("[", lbrack) _("]", rbrack) \
//End Symbolic

#define Enum_name(x,y) y ,

enum token_symbols {
  t_id = SYM2,
  c_int, c_float, c_char, c_string,
  Each_Symbolic( Enum_name )
  SYM3
};

list tokens_from_chars( object v );

int tok_main( void );

pc9tok.c
Implementation of the tokenizer for pre-K&R C. All of the identifiers from the table in the header file are converted into parsers which match the associated string and yield the symbol as output. The next layer can easily match against these symbols. The symbol type object also has an extra data pointer to hold extra stuff. The token functions pack the actual input string and any preliminary whitespace in this pointer in the symbol object. So this data isn't lost, but it's hidden from the parser layer which just deals with token symbols.

#include "pc9tok.h"
#include "pc9objpriv.h"

static object  on_spaces( object v, list o ){ return  string_from_chars( o ); }

static object  on_integer( object v, list o ){ return  cons( Symbol(c_int), string_from_chars( o ) ); }
static object  on_floating( object v, list o ){ return  cons( Symbol(c_float), string_from_chars( o ) ); }
static object  on_character( object v, list o ){ return  cons( Symbol(c_char), string_from_chars( o ) ); }
static object  on_string( object v, list o ){ return  cons( Symbol(c_string), string_from_chars( o ) ); }
static object  on_identifier( object s, list o ){ return  cons( Symbol(t_id), string_from_chars( o ) ); }

#define On_Symbolic(a,b) \
  static object  on_##b( object v, list o ){ return  cons( Symbol(b), string_from_chars( o ) ); }
Each_Symbolic( On_Symbolic )

static parser
token_parser( void ){
  parser space      = using( many( anyof( " \t\n" ) ), on_spaces );
  parser alpha_     = plus( alpha(), chr('_') );
  parser integer    = using( some( digit() ), on_integer );
  parser floating   = using( SEQ( plus( SEQ( some( digit() ), chr('.'), many( digit() ) ),
                                 seq( chr('.'), some( digit() ) ) ),
                                 maybe( SEQ( anyof("eE"), maybe( anyof("+-") ), some( digit() ) ) ) ),
                             on_floating );
  parser escape     = seq( chr('\\'),
                           plus( seq( digit(), maybe( seq( digit(), maybe( digit() ) ) ) ),
                                 anyof( "'\"bnrt\\" ) ) );
  parser char_      = plus( escape, noneof( "'\n" ) );
  parser schar_     = plus( escape, noneof( "\"\n" ) );
  parser character  = using( SEQ( chr('\''), char_, chr('\'') ), on_character );
  parser string     = using( SEQ( chr('"'), many( schar_ ), chr('"') ), on_string );
  parser constant   = PLUS( floating, integer, character, string );
# define Handle_Symbolic(a,b)  using( str( a ), on_##b ),
  parser symbolic   = PLUS( Each_Symbolic( Handle_Symbolic ) zero() );
  parser identifier = using( seq( alpha_, many( plus( alpha_, digit() ) ) ), on_identifier );
  return  seq( space, PLUS( constant, symbolic, identifier ) );
}

static object  on_token( object v, list o ){
  object space = x_( o );
  object symbol = x_( xs_( o ) );
  object string = xs_( xs_( o ) );
  return  symbol->Symbol.data = cons( space, string ),  symbol;
  return  cons( symbol, cons( space, string ) );
}

list
ptokens_from_chars( object s ){
  if(  !valid( s )  ) return  Symbol(EOF);
  static parser p;
  if(  !p  ){
    p = using( token_parser(), on_token );
    add_global_root( p );
  }
  list r = parse( p, s );
  take( 1, r );
  r = x_( r );
  return  cons( x_( r ), Suspension( xs_( r ), ptokens_from_chars ) );
}

list
tokens_from_chars( object s ){
  return  valid( s )  ? Suspension( s, ptokens_from_chars )  : Symbol(EOF);
}


int test_tokens(){
  list tokens = tokens_from_chars( chars_from_string( "'x' auto \"abc\" 12 ;*++'\\42' '\\n' 123 if" ) );
  PRINT( tokens );
  PRINT( take( 1, tokens ) );
  PRINT( take( 2, tokens ) );
  PRINT( drop( 1, tokens ) );
  PRINT( take( 2, drop( 1, tokens ) ) );
  drop( 7, tokens );
  PRINT( tokens );
  PRINT( Int( garbage_collect( tokens ) ) );
  return 0;
}

int tok_main(){
  return
          par_main(),
          test_tokens(),
          0;
}

pc9syn.h
Interface to the Syntax Analyzer for pre-K&R C. Pretty simple this time, just extending the symbol ids and declaring the main parser function.

#define PC9SYN_H
#ifndef PC9TOK_H
  #include "pc9tok.h"
#endif

enum syntax_analysis_symbols {
  func_def = SYM3,
  data_def,
  SYM4
};

list tree_from_tokens( object s );

pc9syn.c
Implementation of the Syntax Analyzer for pre-K&R C. All of the symbols from the tokenizer are converted into parsers which match those symbols and are named with an extra underscore appended. So c_float is an enum, Symbol(c_float) is a symbol object, and c_float_ (with extra underscore) is a parser which matches that token symbol. So all the names in here with underscores, like comma_ semi_ k_if_, are parsers which match against the tokens coming from the input list.

#include "pc9syn.h"
#include "pc9objpriv.h"

#define Extra_Symbols(_) \
  _(t_id) _(c_int) _(c_float) _(c_char) _(c_string)

#define Parser_for_symbolic_(a,b)  parser b##_ = lit( Symbol(b) );
#define Parser_for_symbol_(b)      parser b##_ = lit( Symbol(b) );

static object on_func_def( object v, list o ){ 
  object s = Symbol(func_def); return  s->Symbol.data = o, s;
  return  cons( Symbol(func_def), o ); 
}
static object on_data_def( object v, list o ){
  object s = Symbol(data_def); return  s->Symbol.data = o, s;
}

parser
parser_for_grammar( void ){
  Each_Symbolic( Parser_for_symbolic_ )
  Extra_Symbols( Parser_for_symbol_ )

  parser identifier = t_id_;
  parser asgnop     = PLUS( o_equal_, o_eplus_, o_eminus_, o_estar_, o_eslant_, o_epercent_,
                        o_egtgt_, o_eltlt_, o_eamp_, o_ecaret_, o_epipe_ );
  parser constant   = PLUS( c_int_, c_float_, c_char_, c_string_ );
  parser lvalue     = forward();
  parser expression = forward();

  *lvalue =
      *PLUS(
      identifier,
      seq( o_star_, expression ),
      //SEQ( primary, o_arrow_, identifier ),  // introduces a left-recursion indirectly
      SEQ( lparen_, lvalue, rparen_ )
      );

  parser expression_list = seq( expression, many( seq( comma_, expression ) ) );
  parser primary =
      seq(
       PLUS(
         identifier,
         constant,
         SEQ( lparen_, expression, rparen_ ),
         SEQ( lvalue, o_dot_, identifier )
       ),
       maybe( PLUS(
         SEQ( lparen_, expression_list, rparen_ ),
         SEQ( lbrack_, expression, rbrack_ ),
         seq( o_arrow_, identifier )
       ) )
      );

  *expression =
      *seq(
       PLUS(
         primary,
         seq( o_star_, expression ),
         seq( o_amp_, expression ),
         seq( o_minus_, expression ),
         seq( o_bang_, expression ),
         seq( o_tilde_, expression ),
         seq( o_plusplus_, lvalue ),
         seq( o_minusminus_, lvalue ),
         seq( lvalue, o_plusplus_ ),
         seq( lvalue, o_minusminus_ ),
         seq( k_sizeof_, expression ),
         SEQ( lvalue, asgnop, expression )
       ),
       maybe( PLUS(
                    seq( PLUS( o_star_, o_slant_, o_percent_ ), expression ),
                    seq( PLUS( o_plus_, o_minus_ ), expression ),
                    seq( PLUS( o_ltlt_, o_gtgt_ ), expression ),
                    seq( PLUS( o_lt_, o_le_, o_gt_, o_ge_ ), expression ),
                    seq( PLUS( o_equalequal_, o_ne_ ), expression ),
                    seq( o_amp_, expression ),
                    seq( o_caret_, expression ),
                    seq( o_pipe_, expression ),
                    seq( o_ampamp_, expression ),
                    seq( o_pipepipe_, expression ),
                    SEQ( quest_, expression, colon_, expression ),
                    seq( comma_, expression )
       ) )
      );
  parser constant_expression = expression;

  parser statement  = forward();
  parser statement_list = many( statement );
        *statement  =
        *PLUS(
              seq( expression, semi_ ),
              SEQ( lbrace_, statement_list, rbrace_ ),
              SEQ( k_if_, lparen_, expression, rparen_, statement ),
              SEQ( k_if_, lparen_, expression, rparen_, statement, k_else_, statement ),
              SEQ( k_do_, statement, k_while_, lparen_, expression, rparen_, semi_ ),
              SEQ( k_while_, lparen_, expression, rparen_, statement ),
              SEQ( k_for_, lparen_,
                     maybe( expression ), semi_, maybe( expression ), semi_, maybe( expression ),
                   rparen_, statement ),
              SEQ( k_switch_, lparen_, expression, rparen_, statement ),
              SEQ( k_case_, constant_expression, colon_, statement ),
              SEQ( k_default_, colon_, statement ),
              seq( k_break_, semi_ ),
              seq( k_continue_, semi_ ),
              seq( k_return_, semi_ ),
              SEQ( k_return_, expression, semi_ ),
              SEQ( k_goto_, expression, semi_ ),
              SEQ( identifier, colon_, statement ),
              semi_
        );

  parser constant_expression_list = seq( constant_expression, many( seq( comma_, constant_expression ) ) );
  parser initializer = plus( constant, constant_expression_list );

  parser type_specifier = forward();
  parser declarator_list = forward();
  parser type_declaration = SEQ( type_specifier, declarator_list, semi_ );
  parser type_decl_list = some( type_declaration );
  parser sc_specifier = PLUS( k_auto_, k_static_, k_extern_, k_register_ );
    *type_specifier = *PLUS(
                            k_int_, k_char_, k_float_, k_double_,
                            SEQ( k_struct_, lbrace_, type_decl_list, rbrace_ ),
                            SEQ( k_struct_, identifier, lbrace_, type_decl_list, rbrace_ ),
                            SEQ( k_struct_, identifier )
                           );

  parser declarator = forward();
    *declarator = *seq( PLUS(
                          identifier,
                          seq( o_star_, declarator ),
                          SEQ( lparen_, declarator, rparen_ )
                        ), maybe( PLUS(
                                       seq( lparen_, rparen_ ),
                                       SEQ( lbrack_, constant_expression, rbrack_ )
                        ) )
                      );
    *declarator_list = *seq( declarator, many( seq( comma_, declarator ) ) );
  parser decl_specifiers = PLUS( type_specifier, sc_specifier,
                             seq( type_specifier, sc_specifier ),
                             seq( sc_specifier, type_specifier ) );
  parser declaration = seq( decl_specifiers, maybe( declarator_list ) );
  parser declaration_list = seq( declaration, many( seq( comma_, declaration ) ) );
  parser init_declarator = seq( declarator, maybe( initializer ) );
  parser init_declarator_list = seq( init_declarator, many( seq( comma_, init_declarator ) ) );
  parser data_def = using( SEQ( maybe( k_extern_ ),
                                maybe( type_specifier ),
                                maybe( init_declarator_list ), semi_ ),
                           on_data_def );

  parser parameter_list = maybe( seq( expression, many( seq( comma_, expression ) ) ) );
  parser function_declarator = SEQ( declarator, lparen_, parameter_list, rparen_ );
  parser function_statement = SEQ( lbrace_, maybe( declaration_list ), many( statement ), rbrace_ );
  parser function_body = seq( maybe( type_decl_list ), function_statement );
  parser function_def = using( SEQ( maybe( type_specifier ), function_declarator, function_body ),
                               on_func_def );

  parser external_def = plus( function_def, data_def );
  parser program = some( external_def );

  return  program;
}

list
tree_from_tokens( object s ){
  if(  !s  ) return  NIL_;
  static parser p;
  if(  !p  ){
    p = parser_for_grammar();
    add_global_root( p );
  }
  return  parse( p, s );
}

int test_syntax(){
  char *source =
"\n"
"int i,j,k 5;\n"
"float d 3.4;\n"
"int max(a, b, c)\n"
"int a, b, c;\n"
"{\n"
"      int m;\n"
"      m = (a>b)? a:b;\n"
"      return(m>c? m:c);\n"
"}\n"
"main( ) {\n"
"\tprintf(\"Hello, world\");\n"
"}\n"
"\t if(  2  ){\n\t   x = 5;\n\t   } int auto";
  object tokens = tokens_from_chars( chars_from_string( source ) );
  add_global_root( tokens );
  PRINT( take( 4, tokens ) );
  object program = tree_from_tokens( tokens );
  PRINT( program );
  PRINT( x_( x_(  ( drop( 1, program ), program ) ) ) );
  PRINT_FLAT( x_( x_( program ) ) );
  PRINT_DATA( x_( x_( program ) ) );
  PRINT( xs_( x_( program ) ) );
  PRINT( Int( garbage_collect( program ) ) );
  return  0;
}


int main(){
  return  tok_main(),
          test_syntax(),
          0;
}

Makefile

CFLAGS= -std=c99 -g -Wall -Wpedantic -Wno-switch -Wreturn-type -Wunused-variable
CFLAGS+= $(cflags)

test : pc9
        echo abc j string | ./$<

clean :
        rm *.o

pc9 : pc9obj.o pc9fp.o pc9par.o pc9tok.o pc9syn.o
        $(CC) $(CFLAGS) -o $@ $^ $(LDLIBS)

All told, it's just under 1500 lines.

$ wc -l *[ch]
  128 pc9fp.c
   19 pc9fp.h
  316 pc9obj.c
   54 pc9obj.h
   24 pc9objpriv.h
  529 pc9par.c
   48 pc9par.h
  208 pc9syn.c
   12 pc9syn.h
   85 pc9tok.c
   38 pc9tok.h
   28 ppnarg.h
 1489 total

Output from simple tests. At the very end, the print_data function is used to recover all the strings hidden inside the token symbols in the syntax tree, reconstructing the source code.

$ make -k
cc -std=c99 -g -Wall -Wpedantic -Wno-switch -Wreturn-type -Wunused-variable    -c -o pc9obj.o pc9obj.c
cc -std=c99 -g -Wall -Wpedantic -Wno-switch -Wreturn-type -Wunused-variable    -c -o pc9fp.o pc9fp.c
cc -std=c99 -g -Wall -Wpedantic -Wno-switch -Wreturn-type -Wunused-variable    -c -o pc9par.o pc9par.c
cc -std=c99 -g -Wall -Wpedantic -Wno-switch -Wreturn-type -Wunused-variable    -c -o pc9tok.o pc9tok.c
cc -std=c99 -g -Wall -Wpedantic -Wno-switch -Wreturn-type -Wunused-variable    -c -o pc9syn.o pc9syn.c
cc -std=c99 -g -Wall -Wpedantic -Wno-switch -Wreturn-type -Wunused-variable  -o pc9 pc9obj.o pc9fp.o pc9par.o pc9tok.o pc9syn.o 
echo abc j string | ./pc9
test_basics: ch = ... 
test_basics: Int( garbage_collect( ch ) ) = 0 
test_basics: take( 1, ch ) = (97 _ )
test_basics: Int( garbage_collect( ch ) ) = 4 
test_basics: x_( ch ) = 97 
test_basics: Int( garbage_collect( ch ) ) = 1 
test_basics: x_( xs_( ch ) ) = ... 
test_basics: Int( garbage_collect( ch ) ) = 2 
test_basics: take( 1, x_( xs_( ch ) ) ) = (_ _ )
test_basics: Int( garbage_collect( ch ) ) = 5 
test_basics: take( 5, ch ) = (97 98 99 100 101 _ )
test_basics: Int( garbage_collect( ch ) ) = 12 
test_basics: ch = (97 98 99 100 101 ... )
test_basics: Int( garbage_collect( ch ) ) = 1 
test_basics: take( 6, ch ) = (97 98 99 100 101 102 _ )
test_basics: Int( garbage_collect( ch ) ) = 9 
test_basics: take( 1, ch ) = (97 _ )
test_basics: Int( garbage_collect( ch ) ) = 2 
test_basics: take( 2, ch ) = (97 98 _ )
test_basics: Int( garbage_collect( ch ) ) = 3 
test_basics: take( 2, ch ) = (97 98 _ )
test_basics: Int( garbage_collect( ch ) ) = 3 
test_basics: take( 2, ch ) = (97 98 _ )
test_basics: Int( garbage_collect( ch ) ) = 3 
test_basics: take( 2, ch ) = (97 98 _ )
test_basics: Int( garbage_collect( ch ) ) = 3 
test_env: e = ((X 4 )(F 2 )() )
test_env: assoc( Symbol_( F, "F" ), e ) = 2 
test_env: assoc( Symbol_( X, "X" ), e ) = 4 
test_parsers: parse( p, ch ) = ((42 ... )_ )
test_parsers: Int( garbage_collect( ch ) ) = 33 
test_parsers: parse( q, ch ) = _ 
test_parsers: Int( garbage_collect( ch ) ) = 2 
test_parsers: r = Parser 
test_parsers: parse( r, ch ) = ((97 ... )_ )
test_parsers: x_( parse( r, ch ) ) = (97 ... )
test_parsers: take( 1, x_( parse( r, ch ) ) ) = (97 _ )
test_parsers: x_( take( 1, x_( parse( r, ch ) ) ) ) = 97 
test_parsers: take( 1, x_( take( 1, x_( parse( r, ch ) ) ) ) ) = (_ _ )
test_parsers: parse( bind( r, Operator( 0, b ) ), ch ) = ((-97 ... )... )
test_parsers: Int( garbage_collect( cons( ch, r ) ) ) = 46 
test_parsers: s = Parser 
test_parsers: parse( s, ch ) = ((97 ... )... )
test_parsers: take( 2, parse( s, ch ) ) = ((97 ... )(97 ... )_ )
test_parsers: Int( garbage_collect( ch ) ) = 76 
test_parsers: parse( t, ch ) = ((97 ... )... )
test_parsers: parse( u, ch ) = (((97 32 98 32 99 () )... )... )
test_parsers: Int( garbage_collect( cons( ch, cons( t, u ) ) ) ) = 372 
test_regex: a = regex( "\\." ) = _ 
test_regex: parse( a, chars_from_string( "a" ) ) = _ 
test_regex: parse( a, chars_from_string( "." ) ) = _ 
test_regex: parse( a, chars_from_string( "\\." ) ) = _ 
test_regex: b = regex( "\\\\\\." ) = _ 
test_regex: parse( b, chars_from_string( "\\." ) ) = _ 
test_regex: take( 3, parse( b, chars_from_string( "\\." ) ) ) = _ 
test_regex: r = regex( "a?b+(c).|def" ) = Parser 
test_regex: parse( r, chars_from_string( "abc" ) ) = ... 
test_regex: parse( r, chars_from_string( "abbcc" ) ) = ... 
test_regex: Int( garbage_collect( r ) ) = 13660 
test_regex: s = parse( r, chars_from_string( "def" ) ) = ... 
test_regex: take( 3, s ) = _ 
test_regex: parse( r, chars_from_string( "deff" ) ) = ... 
test_regex: parse( r, chars_from_string( "adef" ) ) = ... 
test_regex: parse( r, chars_from_string( "bcdef" ) ) = ... 
test_regex: Int( garbage_collect( cons( r, s ) ) ) = 130 
test_regex: t = regex( "ac|bd" ) = _ 
test_regex: parse( t, chars_from_string( "ac" ) ) = _ 
test_regex: take( 1, parse( t, chars_from_string( "bd" ) ) ) = _ 
test_regex: Int( garbage_collect( t ) ) = 5294 
test_regex: u = regex( "ab|cd|ef" ) = _ 
test_regex: parse( u, chars_from_string( "ab" ) ) = _ 
test_regex: parse( u, chars_from_string( "cd" ) ) = _ 
test_regex: take( 1, parse( u, chars_from_string( "cd" ) ) ) = _ 
test_regex: parse( u, chars_from_string( "ef" ) ) = _ 
test_regex: take( 1, parse( u, chars_from_string( "ef" ) ) ) = _ 
test_regex: Int( garbage_collect( u ) ) = 7804 
test_regex: v = regex( "ab+(c).|def" ) = Parser 
test_regex: parse( v, chars_from_string( "def" ) ) = _ 
test_regex: take( 2, parse( v, chars_from_string( "def" ) ) ) = _ 
test_regex: w = regex( "a?b|c" ) = Parser 
test_regex: parse( w, chars_from_string( "a" ) ) = ... 
test_regex: parse( w, chars_from_string( "b" ) ) = ... 
test_regex: take( 3, parse( w, chars_from_string( "c" ) ) ) = ((() ... )_ )
test_regex: Int( garbage_collect( w ) ) = 13306 
test_pprintf: Int( pprintf( "%% abc %c %s\n", 'x', "123" ) ) = % abc x 123
12 
test_pscanf: Int( pscanf( "" ) ) = 0 
test_pscanf: Int( pscanf( "abc" ) ) = 0 
test_pscanf: Int( pscanf( "  %c", &c ) ) = 1 
test_pscanf: string_from_chars( Int( c ) ) = "j"
test_pscanf: Int( pscanf( "%s", buf ) ) = 1 
test_pscanf: String( buf, 0 ) = "string"
test_tokens: tokens = ... 
test_tokens: take( 1, tokens ) = (c_char _ )
test_tokens: take( 2, tokens ) = (c_char k_auto _ )
test_tokens: drop( 1, tokens ) = (k_auto ... )
test_tokens: take( 2, drop( 1, tokens ) ) = (k_auto c_string _ )
test_tokens: tokens = (c_char k_auto c_string c_int semi o_star o_plusplus ... )
test_tokens: Int( garbage_collect( tokens ) ) = 28834 
test_syntax: take( 4, tokens ) = (k_int t_id comma t_id _ )
test_syntax: program = ... 
test_syntax: x_( x_( ( drop( 1, program ), program ) ) ) = (data_def data_def func_def func_def () )
test_syntax: x_( x_( program ) ) flat= data_def data_def func_def func_def 
test_syntax: x_( x_( program ) ) data= 
int i,j,k 5;
float d 3.4;
int max(a, b, c)
int a, b, c;
{
      int m;
      m = (a>b)? a:b;
      return(m>c? m:c);
}
main( ) {
        printf("Hello, world");
}
test_syntax: xs_( x_( program ) ) = (k_if ... )
test_syntax: Int( garbage_collect( program ) ) = 434910 
\$\endgroup\$
  • \$\begingroup\$ An earlier, less lazy version of this code was posted in comp.lang.c and received helpful comments which have been applied in the code here. \$\endgroup\$ – luser droog May 14 at 5:33
  • \$\begingroup\$ Have you considered CFLAGS += -Wextra ? \$\endgroup\$ – Toby Speight Jun 19 at 7:36
  • \$\begingroup\$ @TobySpeight I hadn't before, but trying it now it just tells me about unused parameters. They're all in fOper functions which don't use the environment parameter. It's a good point that I should have checked this, but I think it doesn't tell me anything interesting. \$\endgroup\$ – luser droog Jun 19 at 18:04
3
\$\begingroup\$

Bug: singleton objects have no allocation record

Since the garbage collector will try to set the mark() in a SYMBOL object, the T_ object needs a dummy allocation record. NIL_ doesn't need one since an INVALID object will not get marked.

pc9obj.c:

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

Bug: using object fields for non-object data

In the pprintf() and pscanf() functions, the object field in OPERATOR objects sometimes contains a va_list *! The garbage collector might fiddle with the memory around this address if it tries to set the (non-existant) mark(). The copious (void *) casts are a code smell. Better to use the VOID type object to hold this pointer.

Missing functions

There's some for 1 or more, many for 0 or more, maybe for 0 or 1. But there's no function to match n times, or n or more, or n up to m times — these kind of quantifiers.

\$\endgroup\$

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.