#!/bin/sh
# the next line restarts using tclsh \
exec tclsh $0 $*
# Copyright (c) 1996 Dennis Heimbigner.  email dennis@cs.colorado.edu

# define the acceptable flex versions
set flvermin 25
set flvermax 25

set patflex {#define[ 	]+FLEX_SCANNER[ 	]*$}
set patv1 {#define[ 	]+YY_FLEX_MAJOR_VERSION[ 	]}
set patv2 {#define[ 	]+YY_FLEX_MINOR_VERSION[ 	]}

set pattb0 {[^_]+_([a-z]+)\[([0-9]+)\][ 	]=}
set pattb1 {[ 	]*\}[ 	]*;}

set patline {#line[ 	]([0-9]+)[ 	]+\"([^\"]*)\"}

set patact0 {^case[ 	]([0-9]+)[ 	]*:}
set patact1 {[ 	]+case[ 	]+YY_END_OF_BUFFER:}
set patact2 {case YY_STATE_EOF\(([^)]+)\):}
set patact3 {^[ 	]+YY_BREAK}
set patact4 {^YY_RULE_SETUP}
set patact5 {[ 	]*ECHO;}
set patact6 {[ 	]+yyterminate\([ 	]*\)\;}

set patspec {[ 	]+while[ 	]+\([ 	]+yy_base\[yy_current_state\][ 	]+!=[ 	]+([0-9]+)[ 	]\)}

set patrs0 {[ 	]+YY_USER_ACTION}

set patescape {[ 	]*\\[ 	]*$}
set pateol "\n"
set patebr "\}"
set pate ";}"
set patf "\{"
set patg "\};"
set patat {(^[^@]*)@([^@]+)@(.*$)}

set tabmods "public static final"

# indicate if we have the actions section
global noactions

global haveprefix
set haveprefix 0

# array of flags
global flags

proc endline {} {return "\n"}

proc lmember {l val} {
    set ok [lsearch -exact $l $val]
    if {$ok == -1} {return 0}
    return 1
}

# unique append
proc lunion {l val} {
    set ll $l
    set ok [lsearch -exact $l $val]
    if {$ok == -1} {
	lappend ll $val
    }
    return $ll
}

proc scanline {line} {
    switch -regexp $line {
	{#define[ 	]*YY_FLEX_MAJOR_VERSION[ 	]} {numdef YY_FLEX_MAJOR_VERSION $line}
	{#define[ 	]*YY_FLEX_MINOR_VERSION[ 	]} {numdef YY_FLEX_MINOR_VERSION $line}
	{#define[ 	]*YY_NULL[ 	]} {numdef YY_NULL $line}
	{#define[ 	]*YY_MORE_ADJ[ 	]} {numdef YY_MORE_ADJ $line}
	{#define[ 	]*YY_END_OF_BUFFER_CHAR[ 	]} {numdef YY_END_OF_BUFFER_CHAR $line}
	{#define[ 	]*YY_BUF_SIZE[ 	]} {numdef YY_BUF_SIZE $line}
	{#define[ 	]*YY_READ_BUF_SIZE[ 	]} {numdef YY_READ_BUF_SIZE $line}
	{#define[ 	]*EOB_ACT_CONTINUE_SCAN[ 	]} {numdef EOB_ACT_CONTINUE_SCAN $line}
	{#define[ 	]*EOB_ACT_END_OF_FILE[ 	]} {numdef EOB_ACT_END_OF_FILE $line}
	{#define[ 	]*EOB_ACT_LAST_MATCH[ 	]} {numdef EOB_ACT_LAST_MATCH $line}
	{#define[ 	]*YY_START_STACK_INCR[ 	]} {numdef YY_START_STACK_INCR $line}
	{#define[ 	]*YY_BUFFER_NEW[ 	]} {numdef YY_BUFFER_NEW $line}
	{#define[ 	]*YY_BUFFER_NORMAL[ 	]} {numdef YY_BUFFER_NORMAL $line}
	{#define[ 	]*YY_BUFFER_EOF_PENDING[ 	]} {numdef YY_BUFFER_EOF_PENDING $line}
	{#define[ 	]*YY_NUM_RULES[ 	]} {numdef YY_NUM_RULES $line}
	{#define[ 	]*YY_END_OF_BUFFER[ 	]} {numdef YY_END_OF_BUFFER $line}
	{static yyconst short int yy_accept\[[0-9]+\]} {maketable yy_accept $line}
	{static yyconst int yy_ec\[[0-9]+\]} {maketable yy_ec $line}
	{static yyconst int yy_meta\[[0-9]+\]} {maketable yy_meta $line}
	{static yyconst short int yy_base\[[0-9]+\]} {maketable yy_base $line}
	{static yyconst short int yy_def\[[0-9]+\]} {maketable yy_def $line}
	{static yyconst short int yy_nxt\[[0-9]+\]} {maketable yy_nxt $line}
	{static yyconst short int yy_chk\[[0-9]+\]} {maketable yy_chk $line}
	{^#define[ 	]+YY_RULE_SETUP[ 	]} {yyrulesetup}
	{#line[ 	][0-9]+[ 	]+\"[^\"]*\"} {yyprefix $line}
	{#if[ 	]+YY_MAIN} {yysuffix}
	{[ 	]*switch[ 	]+\([ 	]*yy_act[ 	]*\)} {yyactions}
	{[ 	]+while[ 	]+\([ 	]+yy_base\[yy_current_state\][ 	]+!=[ 	]+[0-9]+[ 	]*\)[ 	]*;} {yyspecial $line}
    }
}

# Try to figure out which version of flex we are using
proc scanforversion {} {
    global parms patflex patv1 patv2 flvermin flvermax f
    set major ""
    set minor ""
    # first scan for FLEX_SCANNER marker
    while 1 {
	if {[gets $f l] < 0} {
	    error "eof detected while scanning for flex version"
	}
	if [regexp $patflex $l] {break}
    }
    # scan for major version
    while 1 {
	if {[gets $f l] < 0} {
	    error "eof detected while scanning for flex version"
	}
	if [regexp $patv1 $l] {
	    set n [scan $line "#define %s %d" nm major]
	    if {$n != 2} {error "bad numdef declaration"}
	    break;
	}
    }
    # scan for minor version
    while 1 {
	if {[gets $f l] < 0} {
	    error "eof detected while scanning for flex version"
	}
	if [regexp $patv2 $l] {
	    set n [scan $line "#define %s %d" nm minor]
	    if {$n != 2} {error "bad numdef declaration"}
	    break;
	}
    }
    puts "flex version = $vmajor.$vminor"
    set v "${vmajor}${vminor}"
    if {$v < $flvermin || $v > $flvermax} {
	puts "warning: jf has not been tested on flex version $vmajor.$vminor: treating as $flvermax"
	set $v $flvermax
    }
    set flags(flexversion) $v
    return
}

proc numdef {varnm line} {
    global parms
    set n [scan $line "#define %s %d" nm val]
    if {$n != 2 || $nm != $varnm} {error "bad numdef declaration"}
    set parms($varnm) $val
}

proc yyspecial {line} {
    global parms patspec
    set ok [regexp $patspec $line ignore val]
    if $ok {
	set parms(YY_SPECIAL) $val
    } else {
	error "yyspecial: failed: $line"
    }
}

proc maketable {nm line} {
    global f parms pattb0 pattb1 pateol tablelengths
    set tab ""
    if {![regexp $pattb0 $line ignore nm len]} {
	error "maketable: failed: $line"
    }
    set tablelengths("yy_$nm") $len
    while {[gets $f l] >= 0} {
	if [regexp $pattb1 $l] {
	    set fullname yy_$nm
	    set parms($fullname) $tab
# puts "maketable: yy_$nm"
	    return
	}
	append tab $l
	append tab $pateol
    }
    error "eof detected while scanning table"
}

proc yyactions {} {
    global f parms noactions pateol patline
    global patact0 patact1 patact2 patact3 patact4 patact5 patact6
    set body ""
    # scan for the first real action
    while 1 {
	if {[gets $f l] < 0} {
	    error "eof detected while scanning action switch body"
	}
	if [regexp $patact0 $l ignore caseno] {
	    if {$caseno != 1} {
	        error "malformed action switch body: $l"
	    }
	    break;
	}
    }
    # include the case line
    append body $l [endline]
    # collect the real thing
    while {[gets $f l] >= 0} {
	# test to quit
	if [regexp $patact1 $l] {
	    set parms(actions) $body
	    set noactions 0
	    return
	}
	# suppress line directives
	if [regexp $patline $l] {continue}
	# do some special rewrites
	if [regexp $patact2 $l ignore statename] {
	    set l "case YY_END_OF_BUFFER + 1 + $statename :"
	} elseif [regexp $patact3 $l] {
	    set l "break;"
	} elseif [regexp $patact4 $l] {
	    continue
	} elseif [regexp $patact5 $l] {
	    continue;
	} elseif [regexp $patact6 $l] {
	    regsub $patact6 $l {yylval = null; break;} l
	}
	append body $l
	append body $pateol
    }
    error "eof detected while scanning action switch body: $body"
}

proc yyrulesetup {} {
    global f patrs0 patescape parms
    set body ""
    while {[gets $f l] >= 0} {
	# figure out when to quit
	if [regexp $patrs0 $l] {
	    set parms(YY_RULE_SETUP) $body
#puts "YY_RULE_SETUP=$body"
	    return
	}
#puts "before: $l"
	regsub $patescape $l "\n" l
	regsub -- {->} $l "." l
#puts "after: $l"
	append body $l
    }
    error "yyrulesetup: eof detected while scanning YY_RULE_SETUP macro"
}

proc yyprefix {line} {
    global f parms pateol patline lexinname statetypes
    global haveprefix
    if $haveprefix {return}
    # We assume (for these flex versions) that the prefix
    # is after the definition of YY_FLEX_MAJOR_VERSION
# puts "parm names: [array names parms]"
    if {![lmember [array names parms] YY_FLEX_MAJOR_VERSION]} {return}
    set ok [regexp $patline $line ignore lineno fname]
    if {!$ok} {error "yyprefix: could not parse #line directive"}
# puts "(a)lineno=$lineno; fname=$fname"
    if {$lineno != 1} {
	error "could not find start of user specified prefix"
    }
    set haveprefix 1
    set lexinname $fname
    set prfx ""
    while {[gets $f l] >= 0} {
	# figure out when to quit
	set ok [regexp $patline $l ignore lineno fname]
	if $ok {
# puts "(b)lineno=$lineno; fname=$fname"
	   if {$fname != $lexinname} {
		set parms(prefix) $body
		return
	   }
	   # suppress #line directives
	   continue 
	}
        set n [scan $l "#define %s %d" nm val]
	if {$n == 2} {
	    # should be one of the state types
	    set statetypes($nm) $val
	} else {
	    append body $l
	    append body $pateol
	}
    }
    error "eof detected while scanning user defined prefix code: $body"
}

proc yysuffix {} {
    global f parms pateol patline lexinname
    # skip to #line
    while 1 {
	if {[gets $f l] < 0} {
	    error "yysuffix: unexpected eof detected"
	}
	set ok [regexp $patline $l ignore lineno fname]
	# see if this is the expected file name
	if {$ok && $fname == $lexinname} {break}
    }
    # absorb everything to the end of the file
    # but suppress line directives
    set body ""
    while {[gets $f l] >= 0} {
	if [regexp $patline $l] {continue}
	append body $l
	append body $pateol
    }
    set parms(suffix) $body
    return
}

proc sortstates {} {
    global statetypes sortedstates
# puts "sortstates: [array names statetypes]"
    # invert statetypes
    foreach x [array names statetypes] {
	set v [set statetypes($x)]
# puts "sortstates: $x = $v"
	set inverted($v) $x
	# accum list of token values
	lappend indices $v
    }
    set indices [lsort -integer $indices]
    foreach x $indices {
	lappend sortedstates [set inverted($x)]
    }
# puts "sortstates: sortedstates=$sortedstates"
}

proc scanfile {} {
    global f noactions
    set noactions 1
    while {[gets $f l] >= 0} {
	scanline $l
    }
}

proc getflag {nm {def ""}} {
    global flags
    set namelist [array names flags]
    set ok [lsearch -exact $namelist $nm]
    if {$ok == -1} {
	set flags($nm) $def
    }
    return [set flags($nm)]
}
proc genstates {} {
    global statetypes sortedstates tabmods 
    set val ""
    foreach nm $sortedstates {
	set v [set statetypes($nm)]
	append val "$tabmods int $nm = $v;" [endline]
    }
    return $val
}

proc genconst1 {nm} {
    global tabmods parms
    set s [set parms($nm)]
    return "$tabmods int $nm = $s;\n"
}

proc genconstants {} {
    set val ""
    append val [genconst1 YY_FLEX_MAJOR_VERSION]
    append val [genconst1 YY_FLEX_MINOR_VERSION]
    append val [genconst1 YY_NULL]
    append val [genconst1 YY_MORE_ADJ]
    append val [genconst1 YY_END_OF_BUFFER_CHAR]
    append val [genconst1 YY_BUF_SIZE]
    append val [genconst1 YY_READ_BUF_SIZE]
    append val [genconst1 EOB_ACT_CONTINUE_SCAN]
    append val [genconst1 EOB_ACT_END_OF_FILE]
    append val [genconst1 EOB_ACT_LAST_MATCH]
    append val [genconst1 YY_START_STACK_INCR]
    append val [genconst1 YY_BUFFER_NEW]
    append val [genconst1 YY_BUFFER_NORMAL]
    append val [genconst1 YY_BUFFER_EOF_PENDING]
    append val [genconst1 YY_NUM_RULES]
    append val [genconst1 YY_END_OF_BUFFER]
    append val [genconst1 YY_SPECIAL]
    return $val
}

proc gentable1 {nm typ} {
    global tabmods parms pateol patf patg
    set s [set parms($nm)]
    set val ""
    append val "$tabmods $typ $nm\[\] = " $pateol
    append val $s $patg $pateol $pateol
    return $val
}

proc gentables {} {
    set val ""
    append val [gentable1 yy_accept short]
    append val [gentable1 yy_ec int]
    append val [gentable1 yy_meta int]
    append val [gentable1 yy_base short]
    append val [gentable1 yy_def short]
    append val [gentable1 yy_nxt short]
    append val [gentable1 yy_chk short]
    return $val
}

proc flagsubst {fl {leave 0}} {
    global parms pateol statetypes pate patf patat flags sortedstates
    global tabmods patebr
    set val ""
    switch $fl {

	PREFIX {
	    set val [set parms(prefix)]
	} 

	SUFFIX {
	    set val [set parms(suffix)]
	} 

	ACTIONS {
	    # put switch body here
	    set val [set parms(actions)]
	}

	package {
	    set val [getflag $fl]
	    if {$val != ""} {
		set val "package ${val};"
	    }
	}

	constructor {
	    set val [getflag $fl]
	    if {$val != ""} {
		set val "${val};"
	    }
	}

	CONSTANTS {
	    set val [genconstants]
	}
	
	PROCS {
if 0 {
	    append val "protected void YY_RULE_SETUP()" [endline]
	    append val $patf [endline]
	    append val [set parms(YY_RULE_SETUP)]
	    append val $patebr [endline]
}
	}
	
	STATES {
	    set val [genstates]
	}
	
	TABLES {
	    # put tables here
	    set val [gentables]
	}

	default {
	    if $leave {set defalt "@$fl@"} {set defalt $fl}
	    set val [getflag $fl $defalt]
	}
    }
    return $val
}

proc construct {f ft} {
    global parms pateol statetypes pate patf patat flags 
    while {[gets $ft l] >= 0} { 
	while 1 {
	    set ok [regexp $patat $l ignore left fl right]
	    if {!$ok} {
		puts $f $l
		break;
	    }
# puts "left=$left ; fl=$fl ; right=$right"
	    puts -nonewline $f $left
	    puts -nonewline $f [flagsubst $fl]	
	    set l $right
	}
    }
}

proc construct {f ft} {
    global parms pateol statetypes pate patf patat flags 
    while {[gets $ft l] >= 0} { 
	while 1 {
	    set ok [regexp $patat $l ignore left fl right]
	    if {!$ok} {
		puts $f $l
		break;
	    }
# puts "left=$left ; fl=$fl ; right=$right"
	    puts -nonewline $f $left
	    puts -nonewline $f [flagsubst $fl]	
	    set l $right
	}
    }
}

proc internsubst {value {leave 0}} {
    global parms pateol statetypes pate patf patat flags 
    set newval ""
    while 1 {
	set ok [regexp $patat $value ignore left fl right]
	if {!$ok} {
	    append newval $value
	    break;
	}
# puts "left=$left ; fl=$fl ; right=$right"
	append newval $left [flagsubst $fl $leave]
	set value $right
    }
    return $newval
}

# Make sure that the prefix and suffix are tested for @...@
proc fixprefixsuffix {} {
    global parms
    set parms(prefix) [internsubst [set parms(prefix)] 1]
    set parms(suffix) [internsubst [set parms(suffix)] 1]
}

proc makeoutfile {outf tfile} {
    global f parms pateol statetypes pate patf
    set f [open $outf "w"]
    set ft [open $tfile]
    construct $f $ft
    close $f
}

proc doit0 {pf pairs} {
    global f parms
    set f [open $pf]
    scanfile
    close $f
    sortstates
    fixprefixsuffix
    foreach p $pairs {
	set templatef [lindex $p 0]
	set outf [lindex $p 1]
	makeoutfile $outf $templatef
    }
}

proc pairify {pairlist} {
    set i [llength $pairlist]
    if {($i) % 2 == 1} {
	error "odd number of file pairs specified"
    }	
    set pairs {}
    while {$i > 0} {
	set p [lrange $pairlist 0 1]
	set pairlist [lrange $pairlist 2 end]
	lappend pairs $p
	incr i -2
    }
    return $pairs
}

proc doit {argc argv} {
    global javapath flags
    set flagargs ""
    set dumpflags 0
    set flags(javapath) ""
    set flags(flexversion) ""
    set flags(YYlex) "YYlex"
    set flags(yylex) "yylex"
    set av {}
    set i 0
    while {$i < $argc} {
	set arg [lindex $argv $i]
	if [regexp {^--([a-zA-Z0-9_]+)$} $arg ignore cmd] {
	    if {$cmd == "flags"} {
		set dumpflags 1
	    } else {
		error "unknown option"
	    }
	} elseif [regexp {^-([a-zA-Z0-9_]+)$} $arg ignore cmd] {
	    # take this as a flag to set in templates
	    incr i
	    if {$i < $argc} {
		set arg [lindex $argv $i]
	    } else {
		error "no argument to flag"
	    }
	    set flags($cmd) $arg
	    set flagargs [lunion $flagargs $cmd]
	} else {
	    lappend av $arg
	}
	incr i
    }
    set argv $av
    # first file is the input parse file
    set pf [lindex $argv 0]
    # use the rest of the args as file pairs
    set pairs [pairify [lrange $argv 1 end]]
    doit0 $pf $pairs
    if $dumpflags {
	puts "specified flag values:"
	set allflags [lsort [array names flags]]
	foreach fl $allflags {
	    if [lmember $flagargs $fl] {
		set def [set flags($fl)]
		puts "\t${fl}=\"${def}\""
	    }
	}
	puts "default flags values:"
	foreach fl $allflags {
	    if [lmember $flagargs $fl] { } else {
		set def [set flags($fl)]
		puts "\t${fl}=\"${def}\""
	    }
	}
    }    
}

global argc argv
doit $argc $argv