#!/usr/bin/tclsh8.2
+ package require profiler
+ ::profiler::init
+
+
set debug_level 1
proc debug {level str} {
error "openssl bf-ofb exited unexpectedly"
}
set y [packet-fromstring $x]
- if {[string length $y] != $n*2} { error "binary format failed $n $y" }
return $y
}
}
}
-proc assemble {outvarname format} {
- # format should look like those RFC diagrams.
- # +-+-+ stuff and good formatting is mandatory.
- # Tabs are forbidden.
- #
- # Field names are converted to lowercase; internal spaces
- # are replaced with _. They are then assumed to be
- # variable names in the caller's scope. The packet is
- # assembled from those values (which must all be set)
- # and stored in $varname in the caller's scope.
- #
- # Variables ?_whatever will be *set* with the location of the
- # field in the string (in internal format); the corresponding
- # `whatever' (with the ?_ stripped) will be read when assembling.
- #
- # Field name `0' means set the field to zero.
-
- upvar 1 $outvarname out
- set out {}
- set lno 0
- debug 7 "ASSEMBLY $outvarname\n$format"
- foreach l [split $format "\n"] {
- incr lno
- if {[regexp -nocase {^ *\| +\| *$} $l]} {
- if {![info exists wordbits]} {
- error "vspace not in data @$lno\n?$l?"
- }
- incr words
- } elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
- if {[info exists words]} {
- error "data without delimline @$lno\n?$l?"
+namespace eval Assembler {
+ namespace export assemble assembly-overwrite
+
+ proc assemble {outvarname format} {
+ # format should look like those RFC diagrams.
+ # +-+-+ stuff and good formatting is mandatory.
+ # Tabs are forbidden.
+ #
+ # Field names are converted to lowercase; internal spaces
+ # are replaced with _. They are then assumed to be
+ # variable names in the caller's scope. The packet is
+ # assembled from those values (which must all be set)
+ # and stored in $varname in the caller's scope.
+ #
+ # Variables ?_whatever will be *set* with the location of the
+ # field in the string (in internal format); the corresponding
+ # `whatever' (with the ?_ stripped) will be read when assembling.
+ #
+ # Field name `0' means set the field to zero.
+
+ variable cache
+ upvar 1 $outvarname out
+ if {[catch { set parsed $cache($format) }]} {
+ set parsed [parse $format]
+ set cache($format) $parsed
+ }
+
+ manyset $parsed outbytes lout
+ set out [string repeat 00 $outbytes]
+ foreach {location varname locvarname} $lout {
+ if {"$varname" == "0"} {
+ set value 0
+ } else {
+ set value [uplevel 1 [list set $varname]]
}
- set words 1
- set cue $l
- } elseif {[regexp {^ *[-+]+ *$} $l]} {
- set wordbits 0
- set newlineform {}
- while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
- set atpos([string length $before]) $wordbits
- incr wordbits
- set l "$before=$after"
- append newlineform "@[string length $before]:$wordbits "
+ if {[string length $locvarname]} {
+ upvar 1 $locvarname lv
+ set lv $location
}
- incr wordbits -1
- append newlineform $wordbits
- if {[info exists lineform]} {
- if {"$newlineform" != "$lineform"} {
- error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
+ assembly-overwrite out $location $value
+ }
+ }
+
+ proc parse {format} {
+ set lno 0
+ set outbytes 0
+ debug 7 "ASSEMBLY $format"
+ foreach l [split $format "\n"] {
+ incr lno
+ if {[regexp -nocase {^ *\| +\| *$} $l]} {
+ if {![info exists wordbits]} {
+ error "vspace not in data @$lno\n?$l?"
}
- if {![info exists words] || $words<0} {
- error "consecutive delimlines @$lno\n?$l?"
+ incr words
+ } elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
+ if {[info exists words]} {
+ error "data without delimline @$lno\n?$l?"
}
- append out [string repeat 00 [expr {$words*$wordbits/8}]]
- set l $cue
- while {[regexp -nocase \
- {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
- $l dummy before midpart after]} {
- debug 7 "RWORKG ?$l?"
- set varname [string tolower [string trim $midpart]]
- set varname [string map {{ } _} $varname]
- set p1 [string length $before]
- set p2 [expr {
- [string length $before] +
- [string length $midpart] + 1
- }]
- if {![info exists atpos($p1)] ||
- ![info exists atpos($p2)]} {
- error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
+ set words 1
+ set cue $l
+ } elseif {[regexp {^ *[-+]+ *$} $l]} {
+ set wordbits 0
+ set newlineform {}
+ while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
+ set atpos([string length $before]) $wordbits
+ incr wordbits
+ set l "$before=$after"
+ append newlineform "@[string length $before]:$wordbits "
+ }
+ incr wordbits -1
+ append newlineform $wordbits
+ if {[info exists lineform]} {
+ if {"$newlineform" != "$lineform"} {
+ error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
+ }
+ if {![info exists words] || $words<0} {
+ error "consecutive delimlines @$lno\n?$l?"
}
- set bit1 [expr {
- [string length $out]*4
- - $words*$wordbits
- + $atpos($p1)
- }]
- set bitlen [expr {
- $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
- }]
- set location [list $bit1 $bitlen $outvarname-$varname]
- if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
- debug 7 "LOCATING $varname $location"
- upvar 1 $varname locvarname
- set locvarname $location
- set varname $realvarname
+ incr outbytes [expr {$words*$wordbits/8}]
+ set l $cue
+ while {[regexp -nocase \
+ {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
+ $l dummy before midpart after]} {
+ debug 7 "RWORKG ?$l?"
+ set varname [string tolower [string trim $midpart]]
+ set varname [string map {{ } _} $varname]
+ set p1 [string length $before]
+ set p2 [expr {
+ [string length $before] +
+ [string length $midpart] + 1
+ }]
+ if {![info exists atpos($p1)] ||
+ ![info exists atpos($p2)]} {
+ error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
+ }
+ set bit1 [expr {
+ $outbytes*8
+ - $words*$wordbits
+ + $atpos($p1)
+ }]
+ set bitlen [expr {
+ $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
+ }]
+ set location [list $bit1 $bitlen $varname]
+ if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
+ debug 7 "LOCATING $varname $location"
+ set locvarname $varname
+ set varname $realvarname
+ } else {
+ set locvarname {}
+ }
+ lappend lout $location $varname $locvarname
+ set l "$before="
+ append l [string repeat = [string length $midpart]]
+ append l |$after
}
- if {"$varname" == "0"} {
- set value 0
- } else {
- set value [uplevel 1 [list set $varname]]
+ debug 7 "REMAIN ?$l?"
+ } else {
+ if {$wordbits % 8 || $wordbits >32} {
+ error "bad wordbits $wordbits @$lno ?$l? $newlineform"
}
- assembly-overwrite out $location $value
- set l "$before="
- append l [string repeat = [string length $midpart]]
- append l |$after
+ set lineform $newlineform
}
- debug 7 "REMAIN ?$l?"
+ catch { unset words }
+ } elseif {[regexp {^ *$} $l]} {
} else {
- if {$wordbits % 8 || $wordbits >32} {
- error "bad wordbits $wordbits @$lno ?$l? $newlineform"
- }
- set lineform $newlineform
+ error "huh? @$lno ?$l?"
}
- catch { unset words }
- } elseif {[regexp {^ *$} $l]} {
- } else {
- error "huh? @$lno ?$l?"
}
+ debug 7 "ASSEMBLY\n$outbytes\n$lout\n"
+ return [list $outbytes $lout]
}
- debug 7 "ASSEMBLY\n$out\n"
- return $out
-}
-proc assembly-overwrite {outvarname location value} {
- upvar 1 $outvarname out
- manyset $location bit1 bitlen diag
- debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
- if {$bitlen < 32 && $value >= (1<<$bitlen)} {
- error "$diag $value >= 2**$bitlen"
- }
- if {!($bit1 % 8) && !($bitlen % 8)} {
- set char0no [expr {$bit1/4}]
- set charlen [expr {$bitlen/4}]
- set chareno [expr {$char0no + $charlen -1}]
- set repl [format %0${charlen}x $value]
- set out [string replace $out $char0no $chareno $repl]
- } else {
- while {$bitlen > 0} {
- set byteno [expr {$bit1 / 8}]
- set char0no [expr {$byteno*2}]
- set char1no [expr {$char0no+1}]
- set bytebit [expr {128>>($bit1 % 8)}]
- set byte 0x[string range $out $char0no $char1no]
- debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
- set byte [expr {
- ($value & (1<<($bitlen-1)))
- ? ($byte | $bytebit)
- : ($byte & ~$bytebit)
- }]
- set out [string replace $out $char0no $char1no [format %02x $byte]]
+ proc assembly-overwrite {outvarname location value} {
+ upvar 1 $outvarname out
+ manyset $location bit1 bitlen diag
+ debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
+ if {$bitlen < 32 && $value >= (1<<$bitlen)} {
+ error "$diag $value >= 2**$bitlen"
+ }
+ if {!($bit1 % 8) && !($bitlen % 8)} {
+ set char0no [expr {$bit1/4}]
+ set charlen [expr {$bitlen/4}]
+ set chareno [expr {$char0no + $charlen -1}]
+ set repl [format %0${charlen}x $value]
+ set out [string replace $out $char0no $chareno $repl]
+ } else {
+ while {$bitlen > 0} {
+ set byteno [expr {$bit1 / 8}]
+ set char0no [expr {$byteno*2}]
+ set char1no [expr {$char0no+1}]
+ set bytebit [expr {128>>($bit1 % 8)}]
+ set byte 0x[string range $out $char0no $char1no]
+ debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
+ set byte [expr {
+ ($value & (1<<($bitlen-1)))
+ ? ($byte | $bytebit)
+ : ($byte & ~$bytebit)
+ }]
+ set out [string replace $out $char0no $char1no \
+ [format %02x $byte]]
debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
- incr bitlen -1
- incr bit1
+ incr bitlen -1
+ incr bit1
+ }
}
}
}
-
+namespace import Assembler::*
proc gen_1_ip {mtu} {
# RFC791
} else {
foreach count $argv { emit $count }
}
+
+
+puts [::profiler::dump]
+
+puts ---------------------IWJ
+
+puts [::profiler::print]
+
+puts ---------------------IWJ
+
+foreach i [::profiler::sortFunctions totalRuntime] {
+ manyset $i f v
+ puts [::profiler::print $f]
+}
~ianmdlvl / vinegar-ip.git / commitdiff