Perfect neg float bin multiplier, Tcl

Language: Layout:

#tclsh 8.6

gets stdin v1
gets stdin v2
puts " value 1 is $v1"
puts " value 2 is $v2"

proc sign i {
set g [expr abs($i)]
if { $g == $i } {
set s 1
return $s
} else {
set s 0
return $s
}
}

set sign1 [ sign $v1 ]
set sign2 [ sign $v2 ]
puts " sign of 1st value $sign1"
puts " sign of 2nd value $sign2"

proc dec2bin i {
set tcl_precision 4
set list {}

set B [expr {int($i) }]
set C [expr {$i - $B}]

set C [expr {abs($C)}]

#puts "$C ----1"
set result {}
set result1 {}

if {$B<0} {
set B [expr {abs ($B)}]

} else {

set sign {}
#puts "$B----2"
}
while {$B > 0} {

set result [ expr { $B % 2 } ]$result
set B [expr {$B/2}]
}
while {$C<1} {

set result1 [expr {$C*2}]
#puts "$result1 "
set D [expr {int ($result1) }]

#puts "$D"

set E [expr {$result1 - $D}]

#puts "$E"
set C $E

lappend list $D
set llen [llength $list]
#puts "$llen - - - 5"
#puts "$list "

if {$C==0} {
break
}
}
return "$result . $list"
}

set fn1 [dec2bin $v1]
set bf1 [ join $fn1 ""]
puts \n
puts " Decimal to binary conversion of 1st value $bf1"

set fn2 [dec2bin $v2]
set bf2 [ join $fn2 ""]
puts " Decimal to binary conversion of 2nd value $bf2"

proc exp i {
set a [split $i "."]
#puts $a
set b [llength [split [lindex $a 1] ""]]
return $b
}

set v1e [exp $bf1] 
set v2e [exp $bf2]
puts \n
puts " exponent of 1st value $v1e "
puts " exponent of 2nd value $v2e "
set EXP [expr $v1e + $v2e]
puts " exponent after adding both $EXP "

proc man i {
set a [split $i "."]
return [join $a ""]
}

set v1m [man $bf1]
set v2m [man $bf2]
puts \n
puts "mantessa of 1st value $v1m"
puts "mantessa of 2nd value $v2m"
set bin1 0b$v1m
set bin2 0b$v2m

set sum 0b0
while { $bin2 != 0b0 } {
set sum [expr $sum + $bin1]
set bin2 [expr $bin2 - 1]
}
puts \n
puts " multiple times addition product in decimal is $sum "

proc dec2bin1 i {
 set res {} 
   while {$i>0} {
      set res [expr {$i%2}]$res
     set i [expr {$i/2}]
   }
  if {$res == {}} {set res 0}
  return $res
}

set mul [dec2bin1 $sum]
puts " multiple times addition product in binary is $mul"

if { $EXP != 0 } {
set z [split $mul ""] 
#puts $z
set y [expr [llength $z] - $EXP]
#puts $y

set x [linsert $z $y "."]
#puts $x
set mxb [join $x ""]
puts \n
puts "The result is with the exponential part $mxb"
set w [lindex [ split $mxb "."] 0]
#puts $w
puts \n
if { [ expr $w & 1] == 0 } {
puts " product is even num "
} else {
puts " product is odd num "
}
} else {
puts " The result doesn't have exponential part $mul"
set w [lindex [ split $mul "."] 0]
puts $w
if { [ expr $w & 1] == 0 } {
puts " product is even num "
} else {
puts " product is odd num "
}
}

set sym {}
lappend sym $sign1
lappend sym $sign2
set signs [join $sym ""]
#puts $signs
puts \n

if { $signs == 00 } {
puts " The result is $mxb "

} elseif { $signs == 01 } { 
set k [ split $mul "" ]
set d {}
foreach l $k {
lappend d [ expr !$l ]
}
set f [ expr 0b[ join $d "" ] + 0b1 ]
set h [dec2bin1 $f]
set m [ split $h "" ]
set q [expr [llength $m] - $EXP]
set n [linsert $m $q "."]
puts " As the result is negative the complemented answer is [ join $n "" ]"

} elseif { $signs == 10 } {
set k [ split $mul "" ]
set d {}
foreach l $k {
lappend d [ expr !$l ]
}
set f [ expr 0b[ join $d "" ] + 0b1 ]
set h [dec2bin1 $f]
set m [ split $h "" ]
set q [expr [llength $m] - $EXP]
set n [linsert $m $q "."]
puts " As the result is negative the complemented answer is [ join $n "" ]"

} else {
puts " The result is $mxb "
}

[ - ] Show input
Absolute running time: 0.49 sec, cpu time: 0.02 sec, memory peak: 5 Mb, absolute service time: 0,67 sec