ffi/parsec.rkt
#lang at-exp racket
(require parser-tools/yacc
         parser-tools/lex
         (prefix-in : parser-tools/lex-sre))

(define-tokens value-tokens (ID NUM))
(define-empty-tokens op-tokens (DEFINE ENUM COMMA LPAREN RPAREN LBRACE RBRACE STAR AMP EOF))

(define c-lex
  (lexer
   [(eof) (token-EOF)]
   [(:: "/*" (complement (:: any-string "*/" any-string)) "*/")
    (c-lex input-port)]
   ["#define" (token-DEFINE)]
   ["enum" (token-ENUM)]
   [#\, (token-COMMA)]
   [(:or #\tab #\space #\newline) (c-lex input-port)]
   [(:+ numeric #\-) (token-NUM (string->number lexeme))]
   [(:+ alphabetic numeric #\_) (token-ID (string->symbol lexeme))]
   [#\( (token-LPAREN)]
   [#\) (token-RPAREN)]
   [#\{ (token-LBRACE)]
   [#\} (token-RBRACE)]
   [#\* (token-STAR)]
   [#\& (token-AMP)]
   ))

(define c-parse
  (parser
   (start defs)
   (end EOF)
   (tokens value-tokens op-tokens)
   (error
    (lambda (tok-ok? tok-name tok-value)
      (if tok-ok?
          (error 'c-parser "Error at ~a(~v)" tok-name tok-value)
          (error 'c-parser "Invalid token at ~a(~v)" tok-name tok-value))))

   (grammar    
    [defs [() empty]
      [(def defs) (cons $1 $2)]]
    
    [def [(DEFINE ID expr) (def $2 $3)]
      [(ENUM LBRACE enum-body RBRACE) (enum $3)]]
    
    [enum-body [(ID) (list $1)]
               [(ID COMMA enum-body) (cons $1 $3)]]
    
    [expr [(NUM) $1]
          [(ID) (expr:alias $1)]
          [(LPAREN NUM RPAREN) $2]
          [(LPAREN AMP ID RPAREN) (expr:addr $3)]
          [(LPAREN LPAREN ID STAR RPAREN NUM RPAREN) (expr:ptr 1 $3 $6)]
          [(LPAREN LPAREN ID STAR STAR RPAREN NUM RPAREN) (expr:ptr 2 $3 $7)]
          [(LPAREN LPAREN ID STAR STAR STAR RPAREN NUM RPAREN) (expr:ptr 3 $3 $8)]])))

(struct def (id expr) #:transparent)
(struct enum (ids) #:transparent)
(struct expr:alias (id) #:transparent)
(struct expr:addr (id) #:transparent)
(struct expr:ptr (rank type num) #:transparent)
    
(define (parse-c-header-strs . strs)
  (define-values (in out) (make-pipe))
  (for ([s (in-list strs)]) (display s out))
  (close-output-port out)
  (c-parse (lambda () (c-lex in))))

(provide (all-defined-out))