interfaces/xmaxima/Tkmaxima/Parse.tcl

   1 # -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
   2 #
   3 #       $Id: Parse.tcl,v 1.8 2009-03-27 00:14:45 villate Exp $
   4 #
   5 ###### Parse.tcl ######
   6 ############################################################
   7 # Netmath       Copyright (C) 1998 William F. Schelter     #
   8 # For distribution under GNU public License.  See COPYING. #
   9 ############################################################
  10
  11 global Parser parse_table
  12 if {[info exists Parser]} {catch { unset Parser }}
  13
  14 foreach v  { { ( 120 } { \[ 120 } { ) 120 } { \] 120 }  { ^ 110}
  15 { ^- 110} {* 100} { / 100} {% 100}  {- 90 } { + 90 }
  16 { << 80} { >> 80 } { < 70 } { > 70 } { <= 70 } {>= 70}
  17 { == 60 } { & 50} { | 40 } { , 40 } {= 40}
  18 { && 30 } { || 20 } { ? 10 } { : 10 }  { ; 5 }}  {
  19     set parse_table([lindex $v 0]) [lindex $v 1]
  20     set getOp([lindex $v 0]) doBinary
  21
  22 }
  23
  24 proc binding_power {s} {
  25     global parse_table billy
  26     set billy $s
  27     if { [catch { set tem $parse_table($s) }] } {
  28         return 0
  29     } else {
  30         return $tem
  31     }
  32 }
  33
  34 proc getOneMatch { s inds } {
  35     return [string range $s [lindex $inds 0] [lindex $inds 1]]
  36 }
  37
  38 proc parseTokenize { str } {
  39     regsub  -all {[*][*]} $str "^" str
  40     set ans ""
  41     while { [string length $str ] > 0 } {
  42         #    puts "ans=$ans,str=$str"
  43         set str [string trimleft $str " \t\n" ]
  44         set s [string range $str 0 1]
  45         set bp [binding_power $s]
  46         if { $bp > 0 } {
  47             append ans " $s"
  48             set str [string range $str 2 end]
  49             continue
  50         } else {
  51             set s [string range $s 0 0]
  52             set bp [binding_power $s]
  53             if { $bp > 0 } {
  54                 append ans " $s"
  55                 set str [string range $str 1 end]
  56                 continue
  57             }
  58         }
  59         if { "$s" == "" } {
  60             return $ans
  61         }
  62         if { [regexp -indices {^[0-9.]+([eE][+---]?[0-9]+)?} $str all] } {
  63             append ans " { number [getOneMatch $str $all] }"
  64             # append ans " [getOneMatch $str $all]"
  65             set str [string range $str [expr {1+ [lindex $all 1]}] end]
  66         }  elseif { [regexp -indices {^[$a-zA-Z][a-zA-Z0-9]*} $str all] } {
  67             append ans " { id [getOneMatch $str $all] } "
  68             # append ans " [getOneMatch $str $all]"
  69             set str [string range $str [expr {1+ [lindex $all 1]}] end]
  70         }  else {
  71             error [concat [mc "parser unrecognized:"] "$str"]
  72         }
  73     }
  74     return $ans
  75 }
  76
  77 set Parser(reserved) " acos cos hypo sinh asin cosh log sqrt atan exp log10 tan atan2 floor pow tanh ceil fmod sin abs double int round"
  78
  79 set Parser(help) [join [list [mc \
  80 {
  81 The syntax for the definition of functions is like C, except that it is \
  82 permitted to write x^n instead of pow(x,n).
  83 } ] [mc {
  84 Functions:}] $Parser(reserved) [mc {
  85
  86 Operators:}] " == % & || ( << <= ) : * >=  + && , | < >> - > ^ ? /" ] ""]
  87
  88
  89
  90 proc nexttok { } {
  91     global Parser
  92     set x [lindex $Parser(tokenlist) [incr Parser(tokenind) ]]
  93     # puts "nexttok=$x"
  94     if {[llength $x ] > 1 } {
  95         set Parser(tokenval) [lindex $x 1]
  96         return [lindex $x 0]
  97     } else {
  98         return $x
  99     }
 100 }
 101
 102
 103 #
 104 #-----------------------------------------------------------------
 105 #
 106 # parseToSuffixLists -- Convert EXPR1; EXPR2; ..
 107 # to a list of suffix lists.  Each suffix list is suitable for
 108 # evaluating on a stack machine (like postscript) or for converting
 109 # further into another form.  see parseFromSuffixList.
 110 #  "1+2-3^4;" ==>
 111 #   {number 1} {number 2} + {number 3} {number 4} ^ -
 112 #  Results: suffix list form of the original EXPR
 113 #
 114 #  Side Effects: none
 115 #
 116 #----------------------------------------------------------------
 117 #
 118 proc parseToSuffixLists { a }  {
 119     global    Parser
 120     set Parser(result) ""
 121     set Parser(tokenlist) [parseTokenize $a]
 122     set Parser(tokenind) -1
 123     set Parser(lookahead)  [nexttok]
 124     #puts tokenlist=$Parser(tokenlist)
 125     set ans ""
 126     while { "$Parser(lookahead)" != ""  } {
 127         getExpr  ; parseMatch ";"
 128         #puts "here: $Parser(result) "
 129         append ans "[list       $Parser(result)] "
 130         set Parser(result) ""
 131     }
 132     regsub \\^- $ans {PRE_MINUS ^} ans2
 133     return $ans2
 134 }
 135
 136 proc parseMatch { t } {
 137     global Parser
 138     if { "$t" == "$Parser(lookahead)" } {
 139         set Parser(lookahead)  [nexttok]
 140     } else {
 141         error "syntax error: wanted $t"
 142     }
 143 }
 144
 145 proc emit { s args } {
 146     global Parser
 147     if { "$args" == "" }   {
 148         append Parser(result) " $s"
 149         # puts " $s "
 150     } else {
 151         append Parser(result) " {[lindex $args 0 ] $s}"
 152         #puts " {[lindex $args 0 ] $s} "
 153     }
 154 }
 155
 156 proc getExpr { } {
 157     getExprn 0
 158 }
 159
 160 proc getExprn { n } {
 161     global Parser
 162     #puts "getExpr $n, $Parser(tokenind),$Parser(tokenlist)"
 163     if { $n == 110 } {
 164         getExpr120
 165         return
 166     }
 167
 168     incr n 10
 169     if  { $n == 110 } {
 170         if { "$Parser(lookahead)" == "-" || "$Parser(lookahead)" == "+"  } {
 171             if { "$Parser(lookahead)" == "-" } {
 172                 set this PRE_MINUS
 173             } else {
 174                 set this PRE_PLUS
 175             }
 176             parseMatch $Parser(lookahead)
 177             getExprn $n
 178             #puts "l=$Parser(lookahead),pl=$Parser(result)"
 179             emit $this
 180             return
 181         }
 182
 183     }
 184
 185     getExprn $n
 186     while { 1 } {
 187         if { [binding_power $Parser(lookahead)] == $n } {
 188             set this $Parser(lookahead)
 189             parseMatch $Parser(lookahead)
 190             getExprn $n
 191             if { $n == 110 } {
 192                 set toemit ""
 193                 while { "$this" == "^" &&  "$Parser(lookahead)" == "^" } {
 194                     # puts "p=$Parser(result),$
 195                     set this $Parser(lookahead)
 196                     append toemit " $this"
 197                     parseMatch $Parser(lookahead)
 198                     getExprn $n
 199                 }
 200                 foreach v $toemit { emit $v }
 201             }
 202             emit $this
 203
 204         } else {
 205             return
 206         }
 207     }
 208 }
 209
 210 proc getExpr120 { } {
 211     global Parser
 212     #puts "getExpr120, $Parser(tokenind),[lrange $Parser(tokenlist) $Parser(tokenind) end]"
 213     while { 1 } {
 214         if { "$Parser(lookahead)" == "(" } {
 215             parseMatch $Parser(lookahead)
 216             getExpr
 217             parseMatch ")"
 218             break;
 219         } elseif { $Parser(lookahead) == "id" } {
 220             emit $Parser(tokenval) id
 221
 222             parseMatch $Parser(lookahead)
 223             if { "$Parser(lookahead)" == "(" } {
 224                 getExpr120
 225                 emit funcall
 226             }
 227             break;
 228         } elseif { $Parser(lookahead) == "number" } {
 229             emit $Parser(tokenval) number
 230             parseMatch $Parser(lookahead)
 231             break;
 232         } else {
 233             bgerror [mc "syntax error"]
 234             break;
 235         }
 236     }
 237 }
 238
 239 global getOp
 240 set getOp(PRE_PLUS) doPrefix
 241 set getOp(PRE_MINUS) doPrefix
 242 set getOp(funcall) doFuncall
 243 set getOp(^) doPower
 244 set getOp(:) doConditional
 245 set getOp(?) doConditional
 246
 247 proc doBinary { } {
 248     uplevel 1 {set s $nargs; incr nargs -1 ;
 249     if { "$x" == "," } {
 250         set a($nargs) "$a($nargs) $x $a($s)"
 251     } else {
 252         set a($nargs) "($a($nargs) $x $a($s))"}
 253     }
 254 }
 255
 256 proc doPower { } {
 257     uplevel 1 {set s $nargs; incr nargs -1 ; set a($nargs) "pow($a($nargs),$a($s))" }
 258 }
 259
 260 proc doFuncall {} {
 261     uplevel 1 {
 262         #puts nargs=$nargs
 263         set s $nargs; incr nargs -1 ; set a($nargs) "$a($nargs)($a($s))"
 264     }
 265 }
 266
 267 proc doPrefix {} {
 268     uplevel 1  { if { "$x" == "PRE_MINUS" } { set a($nargs) "-$a($nargs)" } }
 269 }
 270
 271 proc doConditional { } {
 272     set x [uplevel 1 set x]
 273     if { "$x" == "?" } { return }
 274     # must be :
 275     uplevel 1 {
 276         set s $nargs ; incr nargs -2 ;
 277         set a($nargs) "($a($nargs) ? $a([expr {$nargs + 1}]) : $a($s))"
 278     }
 279 }
 280
 281
 282 #
 283 #-----------------------------------------------------------------
 284 #
 285 # parseFromSuffixList --  takes a token list, and turns
 286 # it into a suffix form.  eg: 1 + 2 - 3 ^ 4 --> 1 2 + 3 4 ^ -
 287 #  Results:
 288 #
 289 #  Side Effects:
 290 #
 291 #----------------------------------------------------------------
 292 #
 293 proc parseFromSuffixList { list } {
 294     global getOp
 295     set stack ""
 296     set lim [llength $list]
 297     set i 0
 298     set nargs 0
 299     while { $i < $lim } {
 300         set x [lindex $list $i ]
 301         set bp [binding_power $x]
 302         incr i
 303         # all binary
 304         if { [llength $x] > 1 } {
 305
 306             set a([incr nargs]) [lindex $x 1]
 307
 308         } else {
 309             $getOp($x)
 310         }
 311     }
 312
 313     return $a(1)
 314 }
 315
 316
 317 #
 318 #-----------------------------------------------------------------
 319 #
 320 # parseConvert --  given an EXPRESSION, parse it and find out
 321 # what are the variables, and convert a^b to pow(a,b).  If
 322 # -variables "x y" is given, then x and y will be replaced by $x $y
 323 #  doall 1 is giv
 324 #  Results:
 325 #
 326 #  Side Effects:
 327 #
 328 #----------------------------------------------------------------
 329 #
 330 global Parser
 331 set Parser(convertOptions) {
 332     { doall 0 "convert all variables x to \$x" }
 333     { variables "" "list of variables to change from x to \$x" }
 334 }
 335 proc parseConvert { expr args } {
 336     global   Parser
 337     getOptions $Parser(convertOptions) $args
 338     if { "$expr" == "" } { return [list {} {}] }
 339     set parselist [parseToSuffixLists "$expr;"]
 340     #puts "parselist=$parselist"
 341     catch { unset allvars }
 342     set new ""
 343     set answers ""
 344     foreach lis $parselist {
 345
 346         foreach v $lis {
 347
 348             if { ("[lindex $v 0]" == "id")
 349             && ([llength $v] == 2)
 350             && ([lsearch  $Parser(reserved) [set w [lindex $v 1]]] < 0)
 351         } {
 352             if { ($doall != 0)  || ([lsearch  $variables $w] >= 0) } {
 353                 append new " {id \$$w}"
 354                 set allvars(\$$w) 1
 355             } else {
 356                 set allvars($w) 1
 357                 append new " {$v}"
 358             }
 359         }  else {
 360             if { [llength $v] > 1 } {
 361                 append new " {$v}"
 362             } else {
 363                 append new " $v" }
 364             }
 365         }
 366         #puts "new=$new"
 367         append answers "[list [parseFromSuffixList $new]] "
 368         set new ""
 369     }
 370     return [list $answers [array names allvars]]
 371 }
 372
 373 proc test { s } {
 374     set me [parseFromSuffixList [lindex [parseToSuffixLists "$s;"] 0]]
 375     puts $me
 376     return "[eval expr $s] [eval expr $me]"
 377 }
 378
 379
 380
 381
 382 ## endsource parse.tcl