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

# define the acceptable bison versions
set bvermin 124
set bvermax 125

# Prefix code is terminated on the first occurrence
# of a line beginning with a sharp
set patp {^#}

# pattern to recognize version
set patv {GNU Bison version ([0-9][0-9]*).([0-9][0-9])}

set pateol "\n"
set pat0 {static[^\{]*\{(.*)}
set pat1 {\};[ 	]*}
set patbbr "\{"
set patebr "\};"
set pata {[ 	]*/\* the action file gets copied in in place of this dollarsign \*/}
set patb {yyvsp\[(-?[0-9]+)\]}
set patc {yyvs.tth(\1)}
set patd {#define[ 	]+YYTRANSLATE\(x\)[ 	]+(.*)$}
set pate ";}"
set patf "{"
set patat {(^[^@]*)@([^@]+)@(.*$)}

# expectfile patterns
set pats1 {^state[ 	][ 	]*[0-9][0-9]*}
set patt0 {^[ 	]*([a-zA-Z$_][a-zA-Z$_]*)[ 	][ 	]*shift}
set patt1 {^[ 	]*('[^']')[ 	][ 	]*shift,}
set patt2 {^[ 	]*'''[ 	][ 	]*shift,}
set patt3 {^[ 	]*'\\''[ 	][ 	]*shift,}

set ytnamequote "\"\'\\\"\'\"\,"
set ytnameother {^(["][^"]+["])[,](.*)}
set ytnamenull {,[ 	]+NULL}

set tabmods "public static final"

# indicate if we have the actions section
global noactions

# 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[ 	]*YYFINAL[ 	]} {numdef YYFINAL $line}
	{#define[ 	]*YYFLAG[ 	]} {numdef YYFLAG $line}
	{#define[ 	]*YYNTBASE[ 	]} {numdef YYNTBASE $line}
	{#define[ 	]*YYLAST[ 	]} {numdef YYLAST $line}
	{#define[ 	]*YYTRANSLATE\(x\)} {yytransmac $line}
	{static const char yytranslate\[\]} {maketable yytranslate $line}
	{static const short yyprhs\[\]} {maketable yyprhs $line}
	{static const short yyrhs\[\]} {maketable yyrhs $line}
	{static const short yyrline\[\]} {maketable yyrline $line}
	{static const char \* const yytname\[\]} {maketable yytname $line}
	{static const short yyr1\[\]} {maketable yyr1 $line}
	{static const short yyr2\[\]} {maketable yyr2 $line}
	{static const short yydefact\[\]} {maketable yydefact $line}
	{static const short yydefgoto\[\]} {maketable yydefgoto $line}
	{static const short yypact\[\]} {maketable yypact $line}
	{static const short yypgoto\[\]} {maketable yypgoto $line}
	{static const short yytable\[\]} {maketable yytable $line}
	{static const short yycheck\[\]} {maketable yycheck $line}
	{[ 	]*switch[ 	]+\(yyn\)} {yyactions}
	{#define[ 	]*YYBISON[ 	]} {yyprefix}
	{^\}$} {yysuffix}
    }
}

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 yytransmac {line} {
if 0 {
    global parms
    set n [scan $line {#define YYTRANSLATE(x) ((unsigned)(x) <= %d ? yytranslate[x] : %d)} t1 t2]
    if {$n != 2} {error "bad YYTRANSLATE macro"}
    set parms(YYTRANSLATE) [list $t1 $t2]
} else {
    global parms patd 
    regexp $patd $line ignore body
    regsub {\(unsigned\)} $body {} body
    set parms(YYTRANSLATE) $body
}
}

proc maketable {nm line} {
    global f parms pat0 pat1 pateol
    set tab ""
    regexp $pat0 $line ignore tab
    append tab [endline]
    while {[gets $f l] >= 0} {
	if [regexp $pat1 $l] {
	    append tab $pateol
	    set parms($nm) $tab
	    return
	}
	append tab $l
	append tab $pateol
    }
    error "eof detected while scanning table"
}

proc yyactions {} {
    global f parms pata patb patc pateol noactions
    set body ""
    while {[gets $f l] >= 0} {
	# figure out when to quit
	if [regexp $pata $l] {
	    set parms(actions) $body
	    set noactions 0
	    return
	}
	# fix up references to yyvsp
	regsub -all $patb $l $patc l
	append body $l
	append body $pateol
    }
    error "eof detected while scanning switch body: $body"
}

proc yyprefix {} {
    global f parms pateol tokentypes patp
    # skip initial empty lines
    set endfile [gets $f l]
    while {$endfile >= 0} {
	if {[regexp {^[ 	][ 	]*$} $l] == 0 && $l != ""} {break}
 	set endfile [gets $f l]
    }
    if {$endfile < 0} {
	error "eof detected while looking for token definitions"
    }
# puts "scanning tokens"
    # absorb initial token definitions
    # make sure to use the non-empty line read above
    set endfile 1
    while {$endfile >= 0} {
        set n [scan $l "#define %s %d" nm val]
	if {$n != 2} {break}
	# should be one of the token types
#puts "token $nm = $val"
	set tokentypes($nm) $val
 	set endfile [gets $f l]
    }
    if {$endfile < 0} {error "eof detected while scanning token definitions"}
    # now, everything from here to next preprocessor line
    # is prefix code
    set body $l
    while {[gets $f l] >= 0} {
	# figure out when to quit
	if [regexp $patp $l] {
	    set parms(prefix) $body
#puts "prefix=$body"
	    return
	}
	append body $l [endline]
    }
    error "eof detected while scanning user defined prefix code: $body"
}

proc fixyytname {} {
    global ytnamenull parms
    # remove the occurrence of NULL at the end of yytname table
    set yt [set parms(yytname)]
    regsub $ytnamenull $yt ", null" yt
    set parms(yytname) $yt
}

proc buildnttable {} {
    global nonterms parms ytnamequote ytnameother
    # first, we need to extract the list of nonterms form yytnames
    set yyt [set parms(yytname)]
    set names {}
    while 1 {
	set ch [string range $yyt 0 0]
	# pull off whitespace
	if {$ch == " " || $ch == "	" || $ch == "\n"} {
	    set yyt [string range $yyt 1 end]
	    continue
	}
	# look for embedded double quote
	if {[string range $yyt 0 6] == $ytnamequote} {
	    set nm $ytnamequote
	    set rest [string range $yyt 7 end]
	} else {
	    set ok [regexp $ytnameother $yyt ignore nm rest]
	    if {$ok == 0} {break}
	}
	lappend names $nm
	set yyt $rest
    }
    # now we need to extract the nonterminal names
    set parms(nontermnames) [lrange $names [set parms(YYNTBASE)] end]
    #construct the nonterm constantst
    set ntc {}
    foreach nt [set parms(nontermnames)] {
	regexp {["]([^"]+)["]} $nt ignore n
	lappend ntc $n
    }
    set parms(nonterms) $ntc
}

# Try to figure out which version of bison we are using
# by looking for the string "GNU Bison version x.yy"
proc scanforversion {} {
    global parms patv bvermin bvermax f
    while {[gets $f l] >= 0} {
	if [regexp $patv $l ignore vmajor vminor] {
	    puts "bison version = $vmajor.$vminor"
	    set v "${vmajor}${vminor}"
	    if {$v < $bvermin || $v > $bvermax} {
		puts "warning: jb has not been tested on bison version $vmajor.$vminor: treating as $bvermax"
		set $v $bvermax
	    }
	    set parms(bisonversion) $v
	    return
	}
    }
    error "eof detected while scanning for bison version"
}

proc sorttokens {} {
    global tokentypes sortedtokens
    # invert tokentypes
    foreach x [array names tokentypes] {
	set v [set tokentypes($x)]
	set inverted($v) $x
	# accum list of token values
	lappend indices $v
    }
    set indices [lsort -integer $indices]
    foreach x $indices {
	lappend sortedtokens [set inverted($x)]
    }
}

proc yysuffix {} {
    global f parms pateol tokentypes noactions
    if $noactions return
    set body ""
    # absorb everything to the end of the file
    while {[gets $f l] >= 0} {
	append body $l
	append body $pateol
    }
    set parms(suffix) $body
    return
}

proc scanfile {} {
    global f parms 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 genconst1 {nm} {
    global tabmods parms
    set s [set parms($nm)]
    return "$tabmods int $nm = $s;\n"
}

proc genconstants {} {
    set val ""
    append val [genconst1 YYFINAL]
    append val [genconst1 YYFLAG]
    append val [genconst1 YYNTBASE]
    append val [genconst1 YYLAST]
    return $val
}

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

proc gentables {} {
    set val ""
    append val [gentable1 yytranslate int]
    append val [gentable1 yyprhs int]
    append val [gentable1 yyrhs int]
    append val [gentable1 yyrline int]
    append val [gentable1 yytname String]
    append val [gentable1 yyr1 int]
    append val [gentable1 yyr2 int]
    append val [gentable1 yydefact int]
    append val [gentable1 yydefgoto int]
    append val [gentable1 yypact int]
    append val [gentable1 yypgoto int]
    append val [gentable1 yytable int]
    append val [gentable1 yycheck int]
    return $val
}

proc flagsubst {fl} {
    global parms pateol tokentypes pate patf patat flags sortedtokens
    global tabmods
    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};"
	    }
	}

	TOKENMAX {
		set val [set tokentypes([lrange $sortedtokens end end])]
	}

	TOKENMIN {
		set val [set tokentypes([lindex $sortedtokens 0])]
	}

	TOKENTYPES {
	    foreach nm $sortedtokens {
		set v [set tokentypes($nm)]
		append val "public static final int $nm = $v;\n"
	    }
	}

	TOKENNAMES {
	    foreach nm $sortedtokens {
		set v [set tokentypes($nm)]
		append val {"} $nm {", }
	    }
	    append val {null}
	}

	NONTERMMAX {
		# NONTERMMIN + length(parms(nonterms)) - 1
		set val [set tokentypes([lrange $sortedtokens end end])]
		set n [set parms(nonterms)]
		set l [llength $n]
		incr val $l
	}

	NONTERMMIN {
		# == TOKENMAX+1
		set val [set tokentypes([lrange $sortedtokens end end])]
		incr val
	}

	NONTERMTYPES {
	    # start at NONTERMMIN
	    set index [set tokentypes([lrange $sortedtokens end end])]
	    incr index
	    set prefix [set flags(ntprefix)]
	    set suffix [set flags(ntsuffix)]
	    foreach nm [set parms(nonterms)] {
		append val "public static final int ${prefix}${nm}${suffix} = $index;\n"
		incr index
	    }
	}

	NONTERMNAMES {
	    foreach nm [set parms(nontermnames)] {
		append val $nm {, }
	    }
	    append val {null}
	}

	CONSTANTS {
	    set val [genconstants]
	}

	PROCS {
	    # dump a static proc
	    append val $tabmods { int YYTRANSLATE(int x) }
	    append val $patf
	    append val " return" $pateol
	    append val [set parms(YYTRANSLATE)]
	    append val $pate $pateol $pateol
	}

	TABLES {
	    # put tables here
	    set val [gentables]
	}

	default {
	    set val [getflag $fl $fl]
	}
    }
    return $val
}

proc construct {f ft} {
    global parms pateol tokentypes 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} {
    global parms pateol tokentypes 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]
	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)]]
    set parms(suffix) [internsubst [set parms(suffix)]]
}

proc makeoutfile {outf tfile} {
    global f parms pateol tokentypes 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
    sorttokens
    set parms(expecttable1) "-1"
    set parms(expecttable2) "-1"
    fixyytname
    buildnttable
    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(YYparse) "YYparse"
    set flags(YYlex) "YYlex"
    set flags(yylex) "yylex"
    set flags(ntprefix) "nt_"
    set flags(ntsuffix) ""
    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