/* lparse.c: parse s-expressions,
 * conv to internal form and print.
 * grammar: sexpr --->  alphanum  |  "("   tail
 *          tail  --->  ")"       |  sexpr tail
 */
#include <stdio.h>
#include <string.h>

/* Lisp cells and supporting declarations */
typedef enum {l, a} Stype;  /* list or alpha */
typedef struct scell* Sp;   /* ptr to S-expr */
typedef struct scell {      /* S-expr decl */
            Stype celltype; /* Kind of S-expr? */
            struct {
                Sp first;   /* pointer to car */
                Sp rest;    /* pointer to cdr */
            } lcell;
            char alf;       /* alpha S-expr */
        } Scell;

/* function prototypes */
Sp getsexpr(void); /* fetch next S-expression */
Sp sexpr(void); /* recognize and return S-expr */
Sp tail (void); /* recognize tail end of S-expr */
Sp cons(Sp, Sp); /* tack two S-exprs together */
Sp car(Sp); /* chase first pointer of S-expr */
Sp cdr(Sp); /* chase second pointer of S-expr */
Sp newalfatom(char); /* create new alpha S-expr */
void writesexpr(Sp); /* write an entire S-expr */
void wsexpr(Sp ); /* write S-expr, calls tail */
void wtail(Sp ); /* write tail of S-expression */
Sp err(int); /* error message */
char gettoken(void); /* fetch next token */
char tok; /* holds current token */

void main(void) {
    Sp s;
    s = getsexpr();
    printf("s:             ");writesexpr(s);
    printf("(car s):       ");writesexpr(car(s));
    printf("(cdr s):       ");writesexpr(cdr(s));
    printf("(car (car s)): ");writesexpr(car(car(s)));
    printf("(car (cdr s)): ");writesexpr(car(cdr(s)));
    printf("(cdr (car s)): ");writesexpr(cdr(car(s)));
    printf("(cdr (cdr s)): ");writesexpr(cdr(cdr(s)));
}

/* getsexpr: fetch next S-expression */
Sp getsexpr (void) {
    tok = gettoken();
    return(sexpr());
}

/* sexpr: recognize and return S-expression */
Sp sexpr (void) {
    if (isalnum(tok))
        return(newalfatom(tok));
    if (tok == '(')
        return(tail());
    return(err(0));
}

/* tail: recognize tail end of S-expression */
Sp tail (void) {
    Sp s, t;
    tok = gettoken();
    if (tok == ')') return(NULL);
    s = sexpr();
    t = tail();
    return(cons(s, t));
}

/* cons: tack two S-expressions together */
Sp cons (Sp s, Sp t) {
    Sp r = (Sp) malloc(sizeof(Scell));
    r -> celltype = l;
    r -> lcell.first = s;
    r -> lcell.rest = t;
    return(r);
}

/* car: chase the first pointer of S-expr */
Sp car (Sp s) {
    if (s == NULL) return(err(1));
    if (s -> celltype == l)
        return(s -> lcell.first);
    return(err(2));
}

/* cdr: chase second pointer of S-expr */
Sp cdr (Sp s) {
    if (s == NULL) return(err(3));
    if (s -> celltype == l)
        return(s ->  lcell.rest);
    return(err(4));
}

/* newalfatom: create new alpha S-expr */
static Sp newalfatom (char alfa) {
    Sp r = (Sp) malloc(sizeof(Scell));
    r -> celltype = a;
    r -> alf = alfa;
    return(r);
}

/* writesexpr: write an entire S-expr */
void writesexpr(Sp s) {
    wsexpr(s); printf("\n");
}

/* wsexpr: write S-expr, calls tail */
static void wsexpr(Sp s) {
    if (s == NULL) {
        printf("("); printf(")");
        return;
    }
    if (s -> celltype == a) {
        printf("%c", s -> alf);
        return;
    }
    printf("(");
    wtail(s);
}

/* wtail: write tail of S-expression */
static void wtail(Sp s) {
    if (s == NULL) {
        printf(")");
        return;
    }
    wsexpr(car(s));
    printf(" ");
    wtail(cdr(s));
}

/* err: error message */
Sp err(int i) {
    printf("[Error: %d] ", i);
    return(NULL);
}

/* gettoken: fetch next token (a char) */
char gettoken(void) {
    char ch;
    while (isspace(ch = getchar()) &&
              ch != EOF)
        ;
    return ch;
}

% cc -o lparse lparse.c
% lparse
(a b c)
s:             (a b c )
(car s):       a
(cdr s):       (b c )
(car (car s)): [Error: 2] ()
(car (cdr s)): b
(cdr (car s)): [Error: 4] ()
(cdr (cdr s)): (c )

% lparse
( (a b) c (d (e f) g))
s:             ((a b ) c (d (e f ) g ) )
(car s):       (a b )
(cdr s):       (c (d (e f ) g ) )
(car (car s)): a
(car (cdr s)): c
(cdr (car s)): (b )
(cdr (cdr s)): ((d (e f ) g ) )

% lparse
()
s:             ()
(car s):       [Error: 1] ()
(cdr s):       [Error: 3] ()
(car (car s)): [Error: 1] [Error: 1] ()
(car (cdr s)): [Error: 3] [Error: 1] ()
(cdr (car s)): [Error: 1] [Error: 3] ()
(cdr (cdr s)): [Error: 3] [Error: 3] ()

% lparse
(((a) b (c) d) (e f) (g (h i) j))
s:             (((a ) b (c ) d ) (e f ) 
                     (g (h i ) j ) )
(car s):       ((a ) b (c ) d )
(cdr s):       ((e f ) (g (h i ) j ) )
(car (car s)): (a )
(car (cdr s)): (e f )
(cdr (car s)): (b (c ) d )
(cdr (cdr s)): ((g (h i ) j ) )

% lparse
(a)
s:             (a )
(car s):       a
(cdr s):       ()
(car (car s)): [Error: 2] ()
(car (cdr s)): [Error: 1] ()
(cdr (car s)): [Error: 4] ()
(cdr (cdr s)): [Error: 3] ()

% lparse
(a b)
s:             (a b )
(car s):       a
(cdr s):       (b )
(car (car s)): [Error: 2] ()
(car (cdr s)): b
(cdr (car s)): [Error: 4] ()
(cdr (cdr s)): ()

% lparse
(a (b c ) d)
s:             (a (b c ) d )
(car s):       a
(cdr s):       ((b c ) d )
(car (car s)): [Error: 2] ()
(car (cdr s)): (b c )
(cdr (car s)): [Error: 4] ()
(cdr (cdr s)): (d )