path: root/module/c/parse2.scm

(define-module (c parse2)
  :use-module (hnh util)
  :use-module (system base lalr)
  :export (make-parser
           build-lexical-analyzer
           error-procedure))


(define (make-parser)
  (lalr-parser
   (#{out-table:}# "/tmp/c-parser.txt")
   (#{output:}# c-parser "/tmp/c-parser.scm")
   (#{driver:}# glr)


   (
    ;; keywords
    auto break case char const continue default do double else enum
         extern float for goto if inline int long register restrict
         return short signed sizeof static struct switch typedef union
         unsigned void volatile while _Alignas _Alignof _Atomic _Bool
         _Complex _Generic _Imaginary _Noreturn _Static_assert
         _Thread_local

         ;; punctuators
         ;; 6.4.6
         lbrack rbrack ; []
         lparen rparen ; ()
         lbrace rbrace ; {}
         dot ; .
         ->
         ++ -- & * + - ~ !
         / % << >> < > <= >= == != ^
         pipe pipe2 ; | and || scheme handles these fine, but not emacs
         &&
         ? :
         semicolon
         ...
         = *= /= %= += -= <<= >>= &= ^=
         pipe= ; |=
         comma ; ,
         hash  ; #
         hash2 ; ##
         ;; TODO digraphs

         ;; 6.4
         ;; keyword - already translated
         identifier
         constant
         string-literal
         ;; punctuator - already translated
         )

   (top-level
    (translation-unit)    : $1
    (statement)           : $1
    (constant-expression) : $1)

   ;; compounds

   ;; 6.9
   (translation-unit
    (external-declaration)                  : (list 'translation-unit $1)
    (translation-unit external-declaration) : (append $1 (list $2)))


   (primary-expression
    ;; 6.5.1
    (identifier)               : $1
    (constant)                 : `(constant ,$1)
    (string-literal)           : `(string-constant ,$1)
    ;; output parenthesis skipped, since all forms come with their own
    (lparen expression rparen) : $2
    (generic-selection)        : $1)

   (enumeration-constant
    (identifier))


   ;; 6.5.1.1
   (generic-selection
    (_Generic lparen assignment-expression comma generic-assoc-list rparen) : `(generic ,$3 ,@$5))

   (generic-assoc-list
    (generic-assoc-list comma generic-association) : (append $1 (list $3))
    (generic-association)                          : (list $1))

   (generic-association
    (type-name : assignment-expression) : (cons $1 $3)
    (default   : assignment-expression) : (cons $1 $3))

   ;; 6.5.2
   (postfix-expression
    (postfix-expression lbrack expression rbrack)               : `(idx ,$1 ,$3)
    (postfix-expression lparen rparen)                          : `(,$1)
    (postfix-expression lparen argument-expression-list rparen) : `(,$1 ,@$3)
    (postfix-expression dot identifier)                         : `(dot-access ,$1 ,$3)
    (postfix-expression -> identifier)                          : `(ptr-access ,$1 ,$3)
    (postfix-expression ++)                                     : `(postfix++ ,$1)
    (postfix-expression --)                                     : `(postfix-- ,$1)
    (lparen type-name rparen lbrace initializer-list rbrace)
    (lparen type-name rparen lbrace initializer-list comma rbrace)
    (primary-expression)                                        : $1
    )

   (argument-expression-list
    (argument-expression-list comma assignment-expression) : (append $1 (list $3))
    (assignment-expression)                                : (list $1))

   ;; 6.5.3
   (unary-expression
    (++ unary-expression)              : `(prefix++ ,$2)
    (-- unary-expression)              : `(prefix-- ,$2)
    (unary-operator cast-expression)   : `(,$1 ,$2)
    (sizeof unary-expression)          : `(sizeof (typeof ,$2))
    (sizeof lparen type-name rparen)   : `(sizeof ,$3)
    (_Alignof lparen type-name rparen) : `(alignof ,$3)
    (postfix-expression)               : $1)

   (unary-operator
    (&) : 'pointer-to
    (*) : 'dereference
    (+) : 'unary+       ; separate from + and - for
    (-) : 'unary-       ; easier eval procedure later
    (~) : 'bitwise-not
    (!) : 'not)

   ;; 6.5.4
   (cast-expression
    (lparen type-name rparen cast-expression) : `(as-type ,$2 ,$4)
    (unary-expression)                        : $1)

   ;; 6.5.5
   (multiplicative-expression
    (multiplicative-expression * cast-expression) : `(* ,$1 ,$3)
    (multiplicative-expression / cast-expression) : `(/ ,$1 ,$3)
    (multiplicative-expression % cast-expression) : `(% ,$1 ,$3)
    (cast-expression)                             : $1)

   ;; 6.5.6
   (additive-expression
    (additive-expression + multiplicative-expression) : `(+ ,$1 ,$3)
    (additive-expression - multiplicative-expression) : `(- ,$1 ,$3)
    (multiplicative-expression)                       : $1)


   ;; 6.5.7
   (shift-expression
    (shift-expression << additive-expression) : `(<< ,$1 ,$3)
    (shift-expression >> additive-expression) : `(>> ,$1 ,$3)
    (additive-expression)                     : $1)

   ;; 6.5.8
   (relational-expression
    (relational-expression < shift-expression)  : `(< ,$1 ,$3)
(relational-expression > shift-expression)  : `(> ,$1 ,$3)
    (relational-expression <= shift-expression) : `(<= ,$1 ,$3)
    (relational-expression >= shift-expression) : `(>= ,$1 ,$3)
    (shift-expression)                          : $1)

   ;; 6.5.9
   (equality-expression
    (equality-expression == relational-expression) : `(== ,$1 ,$3)
    (equality-expression != relational-expression) : `(!= ,$1 ,$3)
    (relational-expression)                        : $1)


   ;; 6.5.10
   (AND-expression
    (AND-expression & equality-expression) : `(bitwise-and ,$1 ,$3)
    (equality-expression)                  : $1)

   ;; 6.5.11
   (exclusive-OR-expression
    (exclusive-OR-expression ^ AND-expression) : `(bitwise-xor ,$1 ,$3)
    (AND-expression)                           : $1)

   ;; 6.5.12
   (inclusive-OR-expression
    (inclusive-OR-expression pipe exclusive-OR-expression) : `(bitwise-ior ,$1 ,$3)
    (exclusive-OR-expression)                              : $1)

   ;; 6.5.13
   (logical-AND-expression
    (logical-AND-expression && inclusive-OR-expression) : `(and ,$1 ,$3)
    (inclusive-OR-expression)                           : $1)

   ;; 6.5.14
   (logical-OR-expression
    (logical-OR-expression pipe2 logical-AND-expression) : `(or ,$1 ,$3)
    (logical-AND-expression)                             : $1)

   ;; 6.5.15
   (conditional-expression
    (logical-OR-expression ? expression : conditional-expression) : `(ternary ,$1 ,$3 ,$5)
    (logical-OR-expression)             : $1)

   ;; 6.5.16
   (assignment-expression
    (unary-expression assignment-operator assignment-expression) : `(,$2 ,$1 ,$3)
    (conditional-expression)                                     : $1)

   (assignment-operator
    (=)      : $1
    (*=)     : $1
    (/=)     : $1
    (%=)     : $1
    (+=)     : $1
    (-=)     : $1
    (<<=)    : $1
    (>>=)    : $1
    (&=)     : $1
    (^=)     : $1
    (pipe=)  : $1)

   ;; 6.5.17
   (expression
    (assignment-expression)                  : `(begin ,$1)
    ;; (This is the comma operator)
    (expression comma assignment-expression) : (append $1 (list $3)))

   ;; 6.6 constant expression
   (constant-expression
    (expression) : `(constexpr ,$1))

   ;; 6.7
   (declaration
    (declaration-specifiers init-declarator-list semicolon) : ($2 $1)
    ;; TODO when is declare-specifiers without init-declarator-list case relevant?
    ;; It when enabled, it thinks just about everything is this:
    ;; (compile-string* "int x;")
    ;; ⇒ (translation-unit (define (named x ((type int))) <undefined-value>))
    ;; ⇒ (translation-unit (declare1 ((type int) (type (typedef x)))))
    ;; NOTE this case is for structs
    ;; "struct s;"
    (declaration-specifiers                      semicolon) : `(struct-like-declaration ,$1)

    (static_assert-declaration))

   (declaration-specifiers
    (storage-class-specifier declaration-specifiers) : (cons $1 $2)
    (storage-class-specifier)                        : (list $1)

    (type-specifier declaration-specifiers)          : (cons $1 $2)
    (type-specifier)                                 : (list $1)

    (type-qualifier declaration-specifiers)          : (cons $1 $2)
    (type-qualifier)                                 : (list $1)

    (function-specifier declaration-specifiers)      : (cons $1 $2)
    (function-specifier)                             : (list $1)

    (alignment-specifier declaration-specifiers)     : (cons $1 $2)
    (alignment-specifier)                            : (list $1))



   (init-declarator-list
    (init-declarator-list comma init-declarator) : (lambda (type) (append ($1 type) (list ($3 type))))
    (init-declarator)                            : (lambda (type)          `(begin ,($1 type))))

   (init-declarator
    (declarator = initializer) : (lambda (type) `(define ,($1 type) ,$3))
    (declarator)               : (lambda (type) `(define ,($1 type) <undefined-value>)))


   ;; 6.7.1
   (storage-class-specifier
    (typedef)       :  '(storage typedef)
    (extern)        :  '(storage extern)
    (static)        :  '(storage static)
    (_Thread_local) :  '(storage thread-local)
    (auto)          :  '(storage auto)
    (register)      :  '(storage register))



   ;; 6.7.2.1
   (struct-or-union-specifier
    (struct-or-union            lbrace struct-declaration-list rbrace) : `(,$1             ,$3)
    (struct-or-union identifier lbrace struct-declaration-list rbrace) : `(,$1 (named ,$2) ,$4)
    (struct-or-union identifier)                                       : `(,$1 (named ,$2)))

   (struct-or-union
    (struct) : 'struct
    (union)  : 'union)

   (struct-declaration-list
    (struct-declaration-list struct-declaration) : (append $1 (list $2))
    (struct-declaration)                         : (list 'struct-declaration-list $1)
    )

   (struct-declaration
    (specifier-qualifier-list                        semicolon) : $1
    (specifier-qualifier-list struct-declarator-list semicolon) : ($2 $1)
    (static_assert-declaration))

   (specifier-qualifier-list
    (type-specifier specifier-qualifier-list) : `(specifier-qualifier-list ,$1 ,@(cdr $2))
    (type-specifier)                          : `(specifier-qualifier-list ,$1)

    (type-qualifier specifier-qualifier-list) : `(specifier-qualifier-list ,$1 ,@(cdr $2))
    (type-qualifier)                          : `(specifier-qualifier-list ,$1))

   (struct-declarator-list
    (struct-declarator-list comma struct-declarator) : (lambda (type) (append ($1 type) (list ($3 type))))
    (struct-declarator)                              : (lambda (type) (list 'struct-declarator-list ($1 type)))
    )

   (struct-declarator
    (: constant-expression)            : (lambda (type) `(of-width *nothing*  ,$2))
    (declarator : constant-expression) : (lambda (type) `(of-width ,($1 type) ,$3))
    (declarator)                       : $1)

   ;; 6.7.2.2
   (enum-specifier
    (enum identifier lbrace enumerator-list       rbrace) : `(enum (named ,$2) ,$4)
    (enum            lbrace enumerator-list       rbrace) : `(enum ,$3)

    (enum identifier lbrace enumerator-list comma rbrace) : `(enum (named ,$2) ,$4)
    (enum            lbrace enumerator-list comma rbrace) : `(enum ,$3)

    (enum identifier)                                     : `(enum (named ,$2)))

   (enumerator-list
    (enumerator-list comma enumerator) : (append $1 (list $3))
    (enumerator)                       : (list $1)
    )

   (enumerator
    (enumeration-constant = constant-expression) : (list $1 $3)
    (enumeration-constant)                       : $1
    )

   ;; 6.7.2.4
   (atomic-type-specifier
    (_Atomic lparen type-name rparen) : `(atomic ,$3))

   ;; 6.7.3
   (type-qualifier
    (const)     :  `(qualifier const)
    (restrict)  :  `(qualifier restrict)
    (volatile)  :  `(qualifier volatile)
    (_Atomic)   :  `(qualifier atomic)
    )

   ;; 6.7.4
   (function-specifier
    (inline)     : 'inline
    (_Noreturn)  : 'noterun)

   ;; 6.7.5
   (alignment-specifier
    (_Alignas lparen type-name           rparen) : `(aligned-as ,$3)
    (_Alignas lparen constant-expression rparen) : `(aligned-as ,$3))

   ;; 6.7.6

   (declarator
    (pointer direct-declarator) : (lambda (type) ($2 ($1 type)))
    (direct-declarator)         : (lambda (type) ($1 type)))

   (direct-declarator

    (direct-declarator lbrack type-qualifier-list assignment-expression rbrack ) : (lambda (type) ($1 `(array (of-length (,$3 ,$4))
                                                                                                              (containing ,type))))
    (direct-declarator lbrack                     assignment-expression rbrack ) : (lambda (type) ($1 `(array (of-length ,$3)
                                                                                                              (containing ,type))))
    (direct-declarator lbrack type-qualifier-list                       rbrack ) : (lambda (type) ($1 `(array (of-length (,$3))
                                                                                                              (containing ,type))))
    (direct-declarator lbrack                                           rbrack ) : (lambda (type) ($1 `(array (of-indeterminate-length)
                                                                                                              (containing ,type))))

    (direct-declarator lbrack static type-qualifier-list assignment-expression rbrack) : (lambda (type) `(array (static)
                                                                                                                (containing ,type)
                                                                                                                (of-length (,$3 ,$4))))
    (direct-declarator lbrack static                     assignment-expression rbrack) : (lambda (type) `(array (static)
                                                                                                                (containing ,type)
                                                                                                                (of-length ,$4)))

    ;; TODO static position
    (direct-declarator lbrack type-qualifier-list static assignment-expression rbrack) : (lambda (type) `(array (static)
                                                                                                                (containing ,type)
                                                                                                                (of-length (,$3 ,$4))))

    (direct-declarator lbrack type-qualifier-list * rbrack) : (lambda (type) ($1 '(array (containing ,type) (of-variable-length ,$3))))
    (direct-declarator lbrack                     * rbrack) : (lambda (type) ($1 '(array (containing ,type) (of-variable-length))))

    (direct-declarator lparen parameter-type-list rparen ) : (lambda (returning) ($1 `(procedure (returning ,returning) (taking ,@(cdr $3)))))
    (direct-declarator lparen identifier-list rparen )     : (lambda (returning) ($1 `(procedure (returning ,returning) (taking ,@(cdr $3)))))
    (direct-declarator lparen rparen )                     : (lambda (returning) ($1 `(procedure (returning ,returning) (taking *any*))))

    ( lparen declarator rparen ) : (lambda (type) (list ($2 type)))
    (identifier)                 : (lambda (type) `(named ,$1 ,type))
    )

   (pointer
    (* type-qualifier-list)         : (lambda (to) `(,$2 (pointer-to ,to)))
    (* type-qualifier-list pointer) : (lambda (to) `(,$2 (pointer-to ,($3 to))))
    (* pointer)                     : (lambda (to) `(pointer-to ,($2 to)))
    (*)                             : (lambda (to) `(pointer-to ,to)))

   (type-qualifier-list
    (type-qualifier-list type-qualifier) : (append $1 (list $2))
    (type-qualifier)                     : (list 'type-qualifier-list $1)
    )

   (parameter-type-list
    (parameter-list comma ...)  : `(parameter-list ,$1 ...)
    (parameter-list)            : `(parameter-list ,$1)
    )

   (parameter-list
    (parameter-list comma parameter-declaration) : (append $1 (list $3))
    (parameter-declaration)                      : (list $1)
    )

   (parameter-declaration
    (declaration-specifiers declarator)          : ($2 $1)
    (declaration-specifiers abstract-declarator) : ($2 $1)
    (declaration-specifiers)                     : $1)

   (identifier-list
    (identifier-list comma identifier) : (append $1 (list $3))
    (identifier)                       : (list 'identifier-list $1))

   ;; 6.7.7
   (type-name
    (specifier-qualifier-list abstract-declarator) : ($2 $1)
    (specifier-qualifier-list)                     : $1
    )

   (abstract-declarator
    (pointer direct-abstract-declarator) : (compose $1 $2)
    (pointer)                            : $1
    (        direct-abstract-declarator) : $1
    )

   (direct-abstract-declarator
    ( lparen abstract-declarator rparen ) : (lambda (type) (list ($2 type)))
    (direct-abstract-declarator lbrack type-qualifier-list assignment-expression rbrack ) : (lambda (type) ($1 `(array (of-length (,$3 ,$4))
                                                                                                                       (containing ,type))))
    (direct-abstract-declarator lbrack type-qualifier-list                       rbrack ) : (lambda (type) ($1 `(array (of-length (,$3))
                                                                                                                       (containing ,type))))
    (direct-abstract-declarator lbrack                     assignment-expression rbrack ) : (lambda (type) ($1 `(array (of-length ,$3)
                                                                                                                       (containing ,type))))
    (                           lbrack                                           rbrack ) : (lambda (type) `(array (of-indeterminate-length)
                                                                                                                   (containing ,type)))
    (                           lbrack type-qualifier-list assignment-expression rbrack ) : (lambda (type) `(array (containing ,type)
                                                                                                                   (of-length (,$3 ,$4))))
    (                           lbrack type-qualifier-list                       rbrack ) : (lambda (type) `(array (containing ,type)
                                                                                                                   (of-length (,$3))))

    (direct-abstract-declarator lbrack static type-qualifier-list assignment-expression rbrack ) : (lambda (type) ($1 `(array (static)
                                                                                                                              (of-length (,$4 ,$5))
                                                                                                                              (containing ,type))))
    (direct-abstract-declarator lbrack static                     assignment-expression rbrack ) : (lambda (type) ($1 `(array (static) (of-length ,$4) (containing ,type))))
    (                           lbrack static type-qualifier-list assignment-expression rbrack ) : (lambda (type)     `(array (static) (of-length ,($4 $5)) (containing ,type)))
    (                           lbrack static                     assignment-expression rbrack ) : (lambda (type)     `(array (static) (of-length ,$3) (containing ,type)))

    ;; TODO static position
    (direct-abstract-declarator lbrack type-qualifier-list static assignment-expression rbrack ) : (lambda (type) `(array (static) (of-length (,$3 ,$4)) (containing ,type)))
    (                           lbrack type-qualifier-list static assignment-expression rbrack ) : (lambda (type) `(array (static) (of-length (,$2 ,$3)) (containing ,type)))

    (direct-abstract-declarator lbrack * rbrack) : (lambda (type) ($1 `(array (of-variable-length) (containing ,type))))
    (                           lbrack * rbrack) : (lambda (type) `(array (of-variable-length) (containing ,type)))
    (direct-abstract-declarator lparen parameter-type-list rparen ) : (lambda (returning) ($1 `(procedure (returning ,returning) (taking ,$3))))
    (direct-abstract-declarator lparen                     rparen ) : (lambda (returning) ($1 `(procedure (returning ,returning) (taking *any*))))
    (                           lparen parameter-type-list rparen ) : (lambda (returning)     `(procedure (returning ,returning) (taking ,$2)))
    (                           lparen                     rparen ) : (lambda (returning)     `(procedure (returning ,returning) (taking *any*))))

   ;; 6.7.8
   (typedef-name
    (identifier) : `(typedef ,$1))

   ;; 6.7.9
   (initializer
    (lbrace initializer-list rbrace)       : $2
    (lbrace initializer-list comma rbrace) : $2
    (assignment-expression)                : $1)

   (initializer-list
    (initializer-list comma designation initializer) : (append $1 (list `(designate ,$3 ,$4)))
    (initializer-list comma             initializer) : (append $1 (list $3))
    (designation initializer)                        : `(initializer-list (designate ,$1 ,$2))
    (initializer)                                    : `(initializer-list ,$1))

   (designation
    (designator-list =) : $1)

   (designator-list
    (designator-list designator) : (append $1 (list $2))
    (designator)                 : (list 'designators $1))

   (designator
    (lbrack constant-expression rbrack) : `(idx ,$2)
    (dot identifier)                    : `(slot ,$2))

   ;; 6.7.10
   (static_assert-declaration
    (_Static_assert lparen constant-expression comma string-literal rparen semicolon)
    : `(static-assert ,$3 ,$5))

   ;; 6.8
   (statement
    (labeled-statement)     : $1
    (compound-statement)    : $1
    (expression-statement)  : $1
    (selection-statement)   : $1
    (iteration-statement)   : $1
    (jump-statement)        : $1)

   ;; 6.8.1
   (labeled-statement
    (identifier : statement)               : `(labeled ,$1 ,$3)
    (case constant-expression : statement) : `(case ,$2 ,$4)
    (default : statement)                  : `(case-default ,$3))

   ;; 6.8.2
   (compound-statement
    (lbrace block-item-list rbrace) : `(begin ,$2)
    (lbrace rbrace)                 : '(begin))

   (block-item-list
    (block-item-list block-item)  : (append $1 (list $2))
    (block-item)                  : `(let () ,$1)
    )

   (block-item
    (declaration) : $1
    (statement)   : $1)

   ;; 6.8.3
   (expression-statement
    (expression semicolon) : $1
    (semicolon)            : '(noop))

   (selection-statement
    (if lparen expression rparen statement else statement) : `(if ,$3 ,$5 ,$7)
    (if lparen expression rparen statement)                : `(when ,$3 ,$5)
    (switch lparen expression rparen statement)            : `(switch ,$3 ,$5))

   ;; 6.8.5
   (iteration-statement
    (while lparen expression rparen statement)              : `(while ,$3 ,$5)
    (do statement while lparen expression rparen semicolon) : `(do-while ,$5 ,$2)
    (for lparen expression semicolon expression semicolon expression rparen statement) : `(for (init ,$3) (cond ,$5) (step ,$7) ,$9)
    (for lparen expression semicolon expression semicolon            rparen statement) : `(for (init ,$3) (cond ,$5) (step    ) ,$8)
    (for lparen expression semicolon            semicolon expression rparen statement) : `(for (init ,$3) (cond    ) (step ,$6) ,$8)
    (for lparen            semicolon            semicolon            rparen statement) : `(for (init    ) (cond    ) (step    ) ,$6)
    (for lparen            semicolon expression semicolon expression rparen statement) : `(for (init    ) (cond ,$4) (step ,$6) ,$8)
    (for lparen            semicolon expression semicolon            rparen statement) : `(for (init    ) (cond ,$4) (step    ) ,$7)
    (for lparen declaration expression  semicolon expression rparen statement)         ; TODO
    (for lparen declaration expression  semicolon            rparen statement)
    (for lparen declaration             semicolon expression rparen statement)
    (for lparen declaration             semicolon            rparen statement))

   ;; 6.8.6
   (jump-statement
    (goto identifier semicolon)   : `(goto ,$2)
    (continue semicolon)          : `(continue)
    (break semicolon)             : `(break)
    (return expression semicolon) : `(return ,$2)
    (return semicolon)            : `(return))

   ;; 6.9
   (external-declaration
    (function-definition) : $1
    (declaration)         : $1)

   ;; 6.9.1
   (function-definition
    (declaration-specifiers declarator declaration-list compound-statement)
    (declaration-specifiers declarator                  compound-statement) : `(define ,($2 $1) ,$3))

   (declaration-list
    (declaration-list declaration) : (append $1 (list $2))
    (declaration)                  : `(declaration-list ,$1))


   ;; 6.7.2
   ;; Placed AFTER init-declarator to handle "int x = 5;" case. Otherwise it's
   ;; only treated as a (really badly formed) typedef
   (type-specifier
    (void)                      : `(type ,$1)
    (char)                      : `(type ,$1)
    (short)                     : `(type ,$1)
    (int)                       : `(type ,$1)
    (long)                      : `(type ,$1)
    (float)                     : `(type ,$1)
    (double)                    : `(type ,$1)
    (signed)                    : `(type ,$1)
    (unsigned)                  : `(type ,$1)
    (_Bool)                     : `(type bool)
    (_Complex)                  : `(type complex)
    (atomic-type-specifier)     : `(type ,$1)
    (struct-or-union-specifier) : `(type ,$1)
    (enum-specifier)            : `(type ,$1)
    (typedef-name)              : `(type ,$1))))


(define (build-lexical-analyzer tokens)
  (let ((tokens tokens))
    (lambda ()
      (if (null? tokens)
          '*eoi*
          (begin1 (car tokens)
                  (set! tokens (cdr tokens)))))))


;; (build-lexical-analyzer (list (cons 'string "hello")))

(define (error-procedure a b)
  (throw 'parse-error a b))

;; (parser lexical-analyzer error-procedure)