yaz-asncomp

harvest是一个下载html网页得机器人

# Returns,
#   {c-code, h-code}
# Note: Doesn't take care of enum lists yet.
proc asnSimple {name tname tag implicit tagtype} {
    global inf

    set j "[lindex $tname 1] "

    if {[info exists inf(unionmap,$inf(module),$name)]} {
	set uName $inf(unionmap,$inf(module),$name)
    } else {
	set uName $name
    }

    asnEnum $uName jj
    if {![string length $tag]} {
        set l "\treturn [lindex $tname 0] (o, p, opt, name);" 
    } elseif {$implicit} {
        set l \
  "\treturn odr_implicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" 
    } else {
        set l \
  "\treturn odr_explicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \
    }
    if {[info exists jj]} {
	return [list $l $j $jj]
    } else {
	return [list $l $j]
    }
}

# asnSequence: parses "SEQUENCE { s-list }" and generates C code.
# On entry,
#   $name is the type we are defining
#   $tag tag 
#   $implicit
# Returns,
#   {c-code, h-code}
proc asnSequence {name tag implicit tagtype} {
    global val type inf

    lappend j "struct $inf(vprefix)$name \{"
    set level 0
    set nchoice 0
    if {![string length $tag]} {
        lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), name))"
        lappend l "\t\treturn odr_missing(o, opt, name) && odr_ok (o);"
    } elseif {$implicit} {
        lappend l "\tif (!odr_implicit_settag (o, $tagtype, $tag) ||"
        lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))"
        lappend l "\t\treturn odr_missing(o, opt, name);"
    } else {
        lappend l "\tif (!odr_constructed_begin (o, p, $tagtype, $tag, name))"
        lappend l "\t\treturn odr_missing(o, opt, name);"
        lappend l "\tif (o->direction == ODR_DECODE)"
        lappend l "\t\t*p = ($inf(vprefix)$name *) odr_malloc (o, sizeof(**p));"

        lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), 0))"
        lappend l "\t\{"
        lappend l "\t\t*p = 0;"
        lappend l "\t\treturn 0;"
        lappend l "\t\}"
    }
    lappend l "\treturn"
    while {1} {
        set p [lindex [asnName $name] 0]
        asnMod ltag limplicit ltagtype
        set t [asnType $p]

	set uName { }
	if {[info exists inf(unionmap,$inf(module),$name,$p)]} {
	    set uName $inf(unionmap,$inf(module),$name,$p)
	}

        if {![string compare $t Simple]} {
	    if {[string compare $uName { }]} {
		set enumName $uName
	    } else {
		set enumName $name
	    }
            asnEnum $enumName j
            set opt [asnOptional]
            if {![string length $ltag]} {
                lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&"
            } elseif {$limplicit} {
                lappend l "\t\todr_implicit_tag (o, [lindex $tname 0],"
                lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
            } else {
                lappend l "\t\todr_explicit_tag (o, [lindex $tname 0],"
                lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
            }
            set dec "\t[lindex $tname 1] *$p;"
        } elseif {![string compare $t SequenceOf] && [string length $uName] &&\
		      (![string length $ltag] || $limplicit)} {
            set u [asnType $p]
           
	    if {[llength $uName] < 2} {
		set uName [list num_$p $p]
	    }
            if {[string length $ltag]} {
                if {!$limplicit} {
                    asnError explicittag
                }
                lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
            }
            switch -- $u {
                Simple {
                    asnEnum $name j
                    set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p,"
                    set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
                    lappend j "\tint [lindex $uName 0];"
                    set dec "\t[lindex $tname 1] **[lindex $uName 1];"
                }
                default {
                    set subName [mapName ${name}_$level]
                    asnSub $subName $u {} {} 0 {}
                    
                    set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p,"
                    set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
                    lappend j "\tint [lindex $uName 0];"
                    set dec "\t$inf(vprefix)$subName **[lindex $uName 1];"
                    incr level
                }
            }
            set opt [asnOptional]
            if {$opt} {
                lappend l "\t\t($tmpa"
                lappend l "\t\t  $tmpb || odr_ok(o)) &&"
            } else {
                lappend l "\t\t$tmpa"
                lappend l "\t\t  $tmpb &&"
            }
        } elseif {!$nchoice && ![string compare $t Choice] && \
		      [string length $uName]} {
	    if {[llength $uName] < 3} {
		set uName [list which u $name]
		incr nchoice
	    }
            lappend j "\tint [lindex $uName 0];"
            lappend j "\tunion \{"
            lappend v "\tstatic Odr_arm arm\[\] = \{"
            asnArm $name [lindex $uName 2] v j
            lappend v "\t\};"
            set dec "\t\} [lindex $uName 1];"
            set opt [asnOptional]
            set oa {}
            set ob {}
            if {[string length $ltag]} {
                if {$limplicit} {
                    lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
                    if {$opt} {
                        asnWarning "optional handling missing in CHOICE in SEQUENCE"
			asnWarning " set unionmap($inf(module),$name,$p) to {}"
                    }
                } else {
                    if {$opt} {
                        set la "(("
                    } else {
                        set la ""
                    }
                    lappend l "\t\t${la}odr_constructed_begin (o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&"
                }
            } else {
                if {$opt} {
                    set oa "("
                    set ob " || odr_ok(o))" 
                }
            }
            lappend l "\t\t${oa}odr_choice (o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&"
            if {[string length $ltag]} {
                if {!$limplicit} {
                    if {$opt} {
                        set lb ") || odr_ok(o))"
                    } else {
                        set lb ""
                    }
                    lappend l "\t\todr_constructed_end (o)${lb} &&"
                } 
            }
        } else {
	    set subName [mapName ${name}_$level]
            asnSub $subName $t {} {} 0 {}
            set opt [asnOptional]
            if {![string length $ltag]} {
                lappend l "\t\t$inf(fprefix)${subName} (o, &(*p)->$p, $opt, \"$p\") &&"
            } elseif {$limplicit} {
                lappend l "\t\todr_implicit_tag (o, $inf(fprefix)${subName},"
                lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
            } else {
                lappend l "\t\todr_explicit_tag (o, $inf(fprefix)${subName},"
                lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
            }
            set dec "\t$inf(vprefix)${subName} *$p;"
            incr level
        }
        if {$opt} {
            lappend j "$dec /* OPT */"
        } else {
            lappend j $dec
        }
        if {[string compare $type ,]} break
    }
    lappend j "\}"
    if {[string length $tag] && !$implicit} {
        lappend l "\t\todr_sequence_end (o) &&"
        lappend l "\t\todr_constructed_end (o);"
    } else {
        lappend l "\t\todr_sequence_end (o);"
    }
    if {[string compare $type \}]} {
        asnError "Missing \} got $type '$val'"
    }
    lex
    if {[info exists v]} {
        set l [concat $v $l]
    }
    return [list [join $l \n] [join $j \n]]
}

# asnOf: parses "SEQUENCE/SET OF type" and generates C code.
# On entry,
#   $name is the type we are defining
#   $tag tag 
#   $implicit
# Returns,
#   {c-code, h-code}
proc asnOf {name tag implicit tagtype isset} { 
    global inf

    if {$isset} {
	set func odr_set_of
    } else {
	set func odr_sequence_of
    }

    if {[info exists inf(unionmap,$inf(module),$name)]} {
	set numName $inf(unionmap,$inf(module),$name)
    } else {
	set numName {num elements}
    }

    lappend j "struct $inf(vprefix)$name \{"
    lappend j "\tint [lindex $numName 0];"

    lappend l "\tif (!odr_initmember (o, p, sizeof(**p)))"
    lappend l "\t\treturn odr_missing(o, opt, name);"
    if {[string length $tag]} {
        if {$implicit} {
            lappend l "\todr_implicit_settag (o, $tagtype, $tag);"
        } else {
            asnWarning "Constructed SEQUENCE/SET OF not handled"
        }
    }
    set t [asnType $name]
    switch -- $t {
        Simple {
            asnEnum $name j
            lappend l "\tif ($func (o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1],"
            lappend l "\t\t&(*p)->[lindex $numName 0], name))"
            lappend j "\t[lindex $tname 1] **[lindex $numName 1];"
        }
        default {
            set subName [mapName ${name}_s]
            lappend l "\tif ($func (o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1],"
            lappend l "\t\t&(*p)->[lindex $numName 0], name))"
            lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];"
            asnSub $subName $t {} {} 0 {}
        }
    }
    lappend j "\}"
    lappend l "\t\treturn 1;"
    lappend l "\t*p = 0;"
    lappend l "\treturn odr_missing(o, opt, name);"
    return [list [join $l \n] [join $j \n]]
}

# asnArm: parses c-list in choice
proc asnArm {name defname lx jx} {
    global type val inf

    upvar $lx l
    upvar $jx j
    while {1} {
        set pq [asnName $name]
        set p [lindex $pq 0]
        set q [lindex $pq 1]
        if {![string length $q]} {
            set q $p
	    set p ${defname}_$p
        }
        asnMod ltag limplicit ltagtype
        set t [asnType $q]

        lappend enums "$inf(dprefix)$p"
        if {![string compare $t Simple]} {
            asnEnum $name j
            if {![string length $ltag]} {
                lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
		lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\},"
            } elseif {$limplicit} {
                lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
                lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
            } else {
                lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
                lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
            }
            lappend j "\t\t[lindex $tname 1] *$q;"
        } else {
            set subName [mapName ${name}_$q]
            if {![string compare $inf(dprefix)${name}_$q \
                                 $inf(vprefix)$subName]} {
                set po [string toupper [string index $q 0]][string \
                                                            range $q 1 end]
                set subName [mapName ${name}${po}]
            }
            asnSub $subName $t $tname {} 0 {}
            if {![string length $ltag]} {
                lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
		lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
            } elseif {$limplicit} {
                lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
                lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
            } else {
                lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
                lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
            }
            lappend j "\t\t$inf(vprefix)$subName *$q;"
        }
        if {[string compare $type ,]} break
    }
    if {[string compare $type \}]} {
        asnError "Missing \} got $type '$val'"
    }
    lex
    set level 1
    foreach e $enums {
        lappend j "#define $e $level"
        incr level
    }
    lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}"
}

# asnChoice: parses "CHOICE {c-list}" and generates C code.
# On entry,
#   $name is the type we are defining
#   $tag tag 
#   $implicit
# Returns,
#   {c-code, h-code}
proc asnChoice {name tag implicit tagtype} {
    global type val inf

    if {[info exists inf(unionmap,$inf(module),$name)]} {
	set uName $inf(unionmap,$inf(module),$name)
    } else {
	set uName [list which u $name]
    }

    lappend j "struct $inf(vprefix)$name \{"
    lappend j "\tint [lindex $uName 0];"
    lappend j "\tunion \{"
    lappend l "\tstatic Odr_arm arm\[\] = \{"
    asnArm $name [lindex $uName 2] l j
    lappend j "\t\} [lindex $uName 1];"
    lappend j "\}"
    lappend l "\t\};"
    if {![string length $tag]} {
	lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
	lappend l "\t\treturn odr_missing(o, opt, name);"
	lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
    } elseif {$implicit} {
	lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
	lappend l "\t\treturn odr_missing(o, opt, name);"
	lappend l "\todr_implicit_settag(o, $tagtype, $tag);"
	lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
    } else {
	lappend l "\tif (!*p && o->direction != ODR_DECODE)"
	lappend l "\t\treturn opt;"
	lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))"
	lappend l "\t\treturn odr_missing(o, opt, name);"
	lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
	lappend l "\t\treturn odr_missing(o, opt, name);"
	lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&"
	lappend l "\t\todr_constructed_end(o))"
    }
    lappend l "\t\treturn 1;"
    lappend l "\t*p = 0;"
    lappend l "\treturn odr_missing(o, opt, name);"
    return [list [join $l \n] [join $j \n]]
}

# asnImports: parses i-list in "IMPORTS {i-list}" 
# On return inf(import,..)-array is updated.
# inf(import,"module") is a list of {C-handler, C-type} elements.
# The {C-handler, C-type} is compatible with the $tname as is used by the
# asnType procedure to solve external references.
proc asnImports {} {
    global type val inf file

    while {1} {
        if {[string compare $type n]} {
            asnError "Missing name in IMPORTS list"
        }
        lappend nam $val
        lex
        if {![string compare $type n] && ![string compare $val FROM]} {
            lex
	    
	    if {[info exists inf(filename,$val)]} {
		set fname $inf(filename,$val)
	    } else {
		set fname $val
	    }
	    puts $file(outh) "\#include <$inf(h-dir)${fname}.h>"

            if {[info exists inf(prefix,$val)]} {
                set prefix $inf(prefix,$val)
            } else {
                set prefix $inf(prefix)
            }
            foreach n $nam {
		if {[info exists inf(map,$val,$n)]} {
		    set v $inf(map,$val,$n)
		} else {
		    set v $n
		}
                set w [join [split $v -] _]
                set inf(imports,$n) [list [lindex $prefix 0]$w \
                                          [lindex $prefix 1]$w]
            }
            unset nam
            lex
            if {[string compare $type n]} break
        } elseif {![string compare $type ,]} {
            lex
        } else break
    }
    if {[string compare $type \;]} {
        asnError "Missing ; after IMPORTS list - got $type '$val'"
    }
    lex
}

# asnExports: parses e-list in "EXPORTS {e-list}" 
# This function does nothing with elements in the list.
proc asnExports {} {
    global type val inf

    while {1} {
        if {[string compare $type n]} {
            asnError "Missing name in EXPORTS list"
        }
        set inf(exports,$val) 1
        lex
        if {[string compare $type ,]} break
        lex
    }
    if {[string compare $type \;]} {
        asnError "Missing ; after EXPORTS list - got $type ($val)"
    }
    lex
}

# asnModuleBody: parses a module specification and generates C code.
# Exports lists, imports lists, and type definitions are handled;
# other things are silently ignored.