# -*- tcl -*-
# Lexing C

package require lexbase
package provide clex 2.0

namespace eval clex {
    # Define the lexer symbols for the language 'C', as an example.

    namespace import ::lexbase::*

    DefStart

    DefP (   LPAREN      ; DefP )  RPAREN    ; DefP ->  DEREF
    DefP <   LT          ; DefP <= LE        ; DefP ==  EQ
    DefP >   GT          ; DefP >= GE        ; DefP !=  NE
    DefP \[  LBRACKET    ; DefP \] RBRACKET  ; DefP =   ASSIGN
    DefP \{  LBRACE      ; DefP \} RBRACE    ; DefP *=  MUL_ASSIGN
    DefP .   DOT         ; DefP ,  COMMA     ; DefP /=  DIV_ASSIGN
    DefP ++  INCR_OP     ; DefP -- DECR_OP   ; DefP %=  REM_ASSIGN
    DefP &   ADDR_BITAND ; DefP *  MULT_STAR ; DefP +=  PLUS_ASSIGN
    DefP +   PLUS        ; DefP -  MINUS     ; DefP -=  MINUS_ASSIGN
    DefP ~   BITNOT      ; DefP !  LOGNOT    ; DefP <<= LSHIFT_ASSIGN
    DefP /   DIV         ; DefP %  REM       ; DefP >>= RSHIFT_ASSIGN
    DefP <<  LSHIFT      ; DefP >> RSHIFT    ; DefP &=  BITAND_ASSIGN
    DefP ^   BITEOR      ; DefP && LOGAND    ; DefP ^=  BITEOR_ASSIGN
    DefP |   BITOR       ; DefP || LOGOR     ; DefP |=  BITOR_ASSIGN
    DefP ?   QUERY       ; DefP :  COLON     ; DefP \;  SEMICOLON
    DefP ... ELLIPSIS    ; DefP ~= BITNOT_ASSIGN

    DefK typedef ; DefK extern   ; DefK static ; DefK auto ; DefK register
    DefK void    ; DefK char     ; DefK short  ; DefK int  ; DefK long
    DefK float   ; DefK double   ; DefK signed ; DefK unsigned
    DefK goto    ; DefK continue ; DefK break  ; DefK return
    DefK case    ; DefK default  ; DefK switch
    DefK struct  ; DefK union    ; DefK enum
    DefK while   ; DefK do       ; DefK for
    DefK const   ; DefK volatile
    DefK if      ; DefK else
    DefK sizeof

    DefM COMMENT        ::clex::C_comment_begin   ::clex::C_comment_end
    DefM COMMENT        ::clex::C99_comment_begin ::clex::C99_comment_end
    DefM STRING_LITERAL ::clex::C_string_begin    ::clex::C_string_end
    DefM STRING_LITERAL ::clex::C_char_begin      ::clex::C_char_end  

    # Floats containing '.'s have to be matched early because the '.'
    # is later seen as punctuation.

    DefM CONSTANT ::clex::C_floatA_begin ::clex::C_floatA_end
    DefM CONSTANT ::clex::C_floatB_begin ::clex::C_floatB_end

    DefI IDENT
    DefWS {[ \t\v\f\r\n]+}

    DefRxM {^0x[[:xdigit:]]+} CONSTANT
    DefRxM {^\d+}             CONSTANT

    DefEnd
}

proc ::clex::C_comment_begin {string start} {
    return [string first "/*" $string $start]
}

proc ::clex::C_comment_end {string start} {
    incr start 2 ; # Skip behind /*
    set  stop [string first "*/" $string $start]
    incr stop 1 ; # Skip to /
    return $stop
}

proc ::clex::C99_comment_begin {string start} {
    string first // $string $start
}

proc ::clex::C99_comment_end {string start} {
    regexp -indices -start $start {//(?:\\.|[^\n\\])*(?:\n|$)} $string range
    lindex $range 1
}

proc ::clex::C_string_begin {string start} {
    return [string first "\"" $string $start]
}

proc ::clex::C_string_end {string start} {
    # The next vari-sized thing is a "-quoted string.
    # Finding its end is bit more difficult, because we have
    # to accept \" as one character inside of the string. "

    set from $start
    while 1 {
        incr from
        set stop  [string first "\"" $string $from]

        # Note that we do not use [string first] to look for a \",
        # but simply check the preceding character. That is less
        # expensive than possibly running through the whole string.

        incr stop -1
        if {[string equal [string index $string $stop] "\\"]} {
            incr stop 2
            set from $stop
            continue
        }
        incr stop
        break
    }
    return $stop
}

proc ::clex::C_char_begin {string start} {
    return [string first "'" $string $start]
}

proc ::clex::C_char_end {string start} {
    # The next vari-sized thing is a '-quoted string.
    # Finding its end is bit more difficult, because we have
    # to accept \' as one character inside of the string. "

    set from $start
    while 1 {
        incr from
        set stop  [string first "'"   $string $from]

        # Note that we do not use [string first] to look for a \",
        # but simply check the preceding character. That is less
        # expensive than possibly running through the whole string.

        incr stop -1
        if {[string equal [string index $string $stop] "\\"]} {
            incr stop 2
            set from $stop
            continue
        }
        incr stop
        break
    }
    return $stop
}

proc ::clex::C_floatA_begin {string start} {
    upvar stash stash
    if {[regexp -indices -start $start {\W([0-9]*\.[0-9]+([eEdD][+-]?[0-9]+)?)\W} $string -> match]} {
        #puts a==[string range $string [lindex $match 0] [lindex $match 1]]
        set stash(float-a) [lindex $match 1]
        return [lindex $match 0]
    }
    return -1
}

proc ::clex::C_floatA_end {string start} {
    upvar   stash stash
    return $stash(float-a)
}

proc ::clex::C_floatB_begin {string start} {
    upvar stash stash
    if {[regexp -indices -start $start {\W([0-9]+\.[0-9]*([eEdD][+-]?[0-9]+)?)\W} $string -> match]} {
        #puts b==[string range $string [lindex $match 0] [lindex $match 1]]
        set stash(float-b) [lindex $match 1]
        return [lindex $match 0]
    }
    return -1
}

proc ::clex::C_floatB_end {string start} {
    upvar   stash stash
    return $stash(float-b)
    return -1
}

#!/usr/bin/env tclsh
# -*- tcl -*-

set time  1
set token 1
set raw   1
while {1} {
    switch -exact -- [lindex $argv 0] {
        -notime  {set time  0}
        -notoken {set token 0}
        -noraw   {set raw   0}
        default {break}
    }
    set argv [lrange $argv 1 end]
}


source lexbase.tcl
source clex.tcl

# Read file, lex it, time the execution to measure performance

set data [read [set fh [open [set fname [lindex $argv 0]]]]][close $fh]
set len  [string length $data]
set usec [lindex [time {set res [lexbase::lex $data]}] 0]

foreach {sym attr}  $res  break
foreach {aidx aval} $attr break

if {$time} {
    # Write performance statistics.
    puts __________________________________________________
    puts "$fname:"
    puts "\t$len characters"
    puts "\tLexing in $usec microseconds"
    puts "\t       =  [expr {double($usec)/1000000}] seconds"
    puts "\t       =  [expr {double($usec)/$len}] usec/char"
}

if {$token} {
    # Generate tokenized listing of the input, using the lexing results as input.
    puts __________________________________________________
    set av 0
    foreach s $sym {
        switch -glob -- $s {
            *- {puts "$s <<[lindex $aval [lindex $aidx $av]]>>" ; incr av}
            *  {puts "$s"}
        }
    }
}

if {$raw} {
    # Dump the raw lexer result.
    puts __________________________________________________
    puts Symbols___________________________________________
    puts $sym
    puts ""
    puts Attribute-Indices_________________________________
    puts $aidx
    puts ""
    puts Attribute-Data____________________________________
    puts \{[join $aval "\} \{"]\}
    puts ""
    puts __________________________________________________
}

puts __________________________________________________