From: Mike C. <mik...@us...> - 2002-09-06 01:23:30
|
Update of /cvsroot/maxima/maxima/interfaces/xmaxima/Tkmaxima In directory usw-pr-cvs1:/tmp/cvs-serv14613/Tkmaxima Added Files: Getopt.tcl Parse.tcl Private.tcl Log Message: Broke out Getopt.tcl Private.tcl Parse.tcl --- NEW FILE: Getopt.tcl --- ###### Getopt.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ #####sample option list. Error will be signalled if "Required" option ##### not given. #set dfplotOptions { # {xdot Required {specifies dx/dt = xdot. eg -xdot "x+y+sin(x)^2"} } # {ydot Required {specifies dy/dt = ydot. eg -ydot "x-y^2+exp(x)"} } # {xradius 10 "Width in x direction of the x values" } # {yradius 10 "Height in y direction of the y values"} #} # #----------------------------------------------------------------- # # optLoc -- if $usearray is not 0, then the OPTION is stored # in a hashtable, otherwise in the variable whose name is the # same as OPTION. # Results: a form which when 'set' will allow storing value. # # Side Effects: none # #---------------------------------------------------------------- # proc optLoc { op ar } { # puts "$ar,[lindex $op 0]" # puts "return=$ar\([lindex $op 0]\)" if { "$ar" == 0 } { return [lindex $op 0] } else { #puts "$ar\([lindex $op 0]\)" return "$ar\([lindex $op 0]\)" } } # #----------------------------------------------------------------- # # getOptions -- given OPTLIST a specification for the options taken, # parse the alternating keyword1 value1 keyword2 value2 options_supplied # to make sure they are allowed, and not just typos, and to supply defaults # for ones not given. Give an error message listing options. # a specification is { varname default_value "doc string" } # and optlist, is a list of these. the key should be -varname # # -debug 1 "means print the values on standard out" # -allowOtherKeys 1 "dont signal an error if -option is supplied but not in # the list" # -usearray "should give a NAME, so that options are stored in NAME(OPTION) # -setdefaults "if not 0 (default is 1) do `set OPTION dflt' for all options" # If a key is specified twice eg. -key1 val1 -key1 val2, then the first # value val1 will be used # Results: # # Side Effects: set the values in the callers environment # #---------------------------------------------------------------- # proc getOptions { optlist options_supplied args } { # global getOptionSpecs set ar [assoc -usearray $args 0] set help [assoc -help $args ""] if { "$ar" != "0" } { global $ar } set debug [assoc -debug $args 0] set allowOtherKeys [assoc -allowOtherKeys $args 0] set setdefaults [assoc -setdefaults $args 1] set supplied "" foreach {key val } $options_supplied { if { [info exists already($key)] } { continue } set already($key) 1 set found 0 foreach op $optlist { if { "$key" == "-[lindex $op 0]" } { uplevel 1 set [optLoc $op $ar] [list $val] append supplied " [lindex $op 0]" set found 1 break } } set caller global if { $found == 0 && !$allowOtherKeys } { catch {set caller [lindex [info level -1] 0]} error "`$caller' does not take the key `$key':\n[optionHelpMessage $optlist]\n$help" } } foreach op $optlist { if { [lsearch $supplied [lindex $op 0]] < 0 } { if { "[lindex $op 1]" == "Required" } { catch {set caller [lindex [info level -1] 0]} error "`-[lindex $op 0]' is required option for `$caller':\n[optionHelpMessage $optlist]" } if { $setdefaults } { uplevel 1 set [optLoc $op $ar] [list [lindex $op 1]] } } # for debugging see them. # if { $debug } { uplevel 1 puts "[optLoc $op $ar]=\$[optLoc $op $ar]"} if { $debug } { puts "[optLoc $op $ar]=[safeValue [optLoc $op $ar] 2]"} } } proc getOptionDefault { key optionList } { foreach v $optionList { if { "[lindex $v 0]" == "$key" } { return [lindex $v 1]} } return "" } proc assq {key list {dflt ""}} { foreach v $list { if { "[lindex $v 0]" == "$key" } { return $v }} return $dflt } proc safeValue { loc level} { if { ![catch { set me [uplevel $level set $loc] } ] } { return $me } else {return "`unset'" } } proc optionFirstItems { lis } { set ans "" foreach v $lis { append ans " [list [lindex $v 0]]" } return $ans } proc optionHelpMessage { optlist } { set msg "" foreach op $optlist { append msg \ " -[lindex $op 0] \[ [lindex $op 1] \] --[lindex $op 2]\n" } return $msg } # #----------------------------------------------------------------- # # setSplittingOptionsRest -- takes ARGLIST and splits it into # two lists, the first part it stores in KEYPAIRS and the second in REST # # # Results: none # # # Side Effects: sets the variables in the local frame passed to KEYPAIRS # #---------------------------------------------------------------- # proc setSplittingOptionsRest { keypairs rest arglist } { upvar 1 $keypairs keys upvar 1 $rest res set i 0 while { 1 } { if { $i >= [llength $arglist] } { break } if { "[string range [lindex $arglist $i] 0 0]" == "-" } { incr i 2 } else { break } } set keys [lrange $arglist 0 [expr $i -1]] set res [lrange $arglist $i end] } ## endsource getopt.tcl --- NEW FILE: Parse.tcl --- ###### parse.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ global Parser parse_table if {[info exists Parser]} {catch { unset Parser }} foreach v { { ( 120 } { \[ 120 } { ) 120 } { \] 120 } { ^ 110} {* 100} { / 100} {% 100} {- 90 } { + 90 } { << 80} { >> 80 } { < 70 } { > 70 } { <= 70 } {>= 70} { == 60 } { & 50} { | 40 } { , 40 } {= 40} { && 30 } { || 20 } { ? 10 } { : 10 } { ; 5 }} { set parse_table([lindex $v 0]) [lindex $v 1] set getOp([lindex $v 0]) doBinary } proc binding_power {s} { global parse_table billy set billy $s if { [catch { set tem $parse_table($s) }] } { return 0 } else { return $tem } } proc getOneMatch { s inds } { return [string range $s [lindex $inds 0] [lindex $inds 1]] } proc parseTokenize { str } { regsub -all {[*][*]} $str "^" str set ans "" while { [string length $str ] > 0 } { # puts "ans=$ans,str=$str" set str [string trimleft $str " \t\n" ] set s [string range $str 0 1] set bp [binding_power $s] if { $bp > 0 } { append ans " $s" set str [string range $str 2 end] continue } else { set s [string range $s 0 0] set bp [binding_power $s] if { $bp > 0 } { append ans " $s" set str [string range $str 1 end] continue } } if { "$s" == "" } { return $ans } if { [regexp -indices {^[0-9.]+([eE][+---]?[0-9]+)?} $str all] } { append ans " { number [getOneMatch $str $all] }" # append ans " [getOneMatch $str $all]" set str [string range $str [expr {1+ [lindex $all 1]}] end] } elseif { [regexp -indices {^[$a-zA-Z][a-zA-Z0-9]*} $str all] } { append ans " { id [getOneMatch $str $all] } " # append ans " [getOneMatch $str $all]" set str [string range $str [expr {1+ [lindex $all 1]}] end] } else { error "parser unrecognized: $str" } } return $ans } 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" set Parser(help) [join [list { The syntax is like C except that it is permitted to write x^n instead of pow(x,n). } "\nFunctions: $Parser(reserved)\n\nOperators: == % & || ( << <= ) : * >= + && , | < >> - > ^ ? /" ] ""] proc nexttok { } { global Parser set x [lindex $Parser(tokenlist) [incr Parser(tokenind) ]] # puts "nexttok=$x" if {[llength $x ] > 1 } { set Parser(tokenval) [lindex $x 1] return [lindex $x 0] } else { return $x } } # #----------------------------------------------------------------- # # parseToSuffixLists -- Convert EXPR1; EXPR2; .. # to a list of suffix lists. Each suffix list is suitable for # evaluating on a stack machine (like postscript) or for converting # further into another form. see parseFromSuffixList. # "1+2-3^4;" ==> # {number 1} {number 2} + {number 3} {number 4} ^ - # Results: suffix list form of the original EXPR # # Side Effects: none # #---------------------------------------------------------------- # proc parseToSuffixLists { a } { global Parser set Parser(result) "" set Parser(tokenlist) [parseTokenize $a] set Parser(tokenind) -1 set Parser(lookahead) [nexttok] #puts tokenlist=$Parser(tokenlist) set ans "" while { "$Parser(lookahead)" != "" } { getExpr ; parseMatch ";" #puts "here: $Parser(result) " append ans "[list $Parser(result)] " set Parser(result) "" } return $ans } proc parseMatch { t } { global Parser if { "$t" == "$Parser(lookahead)" } { set Parser(lookahead) [nexttok] } else { error "syntax error: wanted $t"} } proc emit { s args } { global Parser if { "$args" == "" } { append Parser(result) " $s" # puts " $s " } else { append Parser(result) " {[lindex $args 0 ] $s}" #puts " {[lindex $args 0 ] $s} " } } proc getExpr { } { getExprn 0 } proc getExprn { n } { global Parser #puts "getExpr $n, $Parser(tokenind),$Parser(tokenlist)" if { $n == 110 } { getExpr120 return } incr n 10 if { $n == 110 } { if { "$Parser(lookahead)" == "-" || "$Parser(lookahead)" == "+" } { if { "$Parser(lookahead)" == "-" } { set this PRE_MINUS } else { set this PRE_PLUS } parseMatch $Parser(lookahead) getExprn $n #puts "l=$Parser(lookahead),pl=$Parser(result)" emit $this return } } getExprn $n while { 1 } { if { [binding_power $Parser(lookahead)] == $n } { set this $Parser(lookahead) parseMatch $Parser(lookahead) getExprn $n if { $n == 110 } { set toemit "" while { "$this" == "^" && "$Parser(lookahead)" == "^" } { # puts "p=$Parser(result),$ set this $Parser(lookahead) append toemit " $this" parseMatch $Parser(lookahead) getExprn $n } foreach v $toemit { emit $v } } emit $this } else { return } } } proc getExpr120 { } { global Parser #puts "getExpr120, $Parser(tokenind),[lrange $Parser(tokenlist) $Parser(tokenind) end]" while { 1 } { if { "$Parser(lookahead)" == "(" } { parseMatch $Parser(lookahead) getExpr parseMatch ")" break; } elseif { $Parser(lookahead) == "id" } { emit $Parser(tokenval) id parseMatch $Parser(lookahead) if { "$Parser(lookahead)" == "(" } { getExpr120 emit funcall } break; } elseif { $Parser(lookahead) == "number" } { emit $Parser(tokenval) number parseMatch $Parser(lookahead) break; } else { error "syntax error" } } } global getOp set getOp(PRE_PLUS) doPrefix set getOp(PRE_MINUS) doPrefix set getOp(funcall) doFuncall set getOp(^) doPower set getOp(:) doConditional set getOp(?) doConditional proc doBinary { } { uplevel 1 {set s $nargs; incr nargs -1 ; if { "$x" == "," } { set a($nargs) "$a($nargs) $x $a($s)"} else { set a($nargs) "($a($nargs) $x $a($s))"} } } proc doPower { } { uplevel 1 {set s $nargs; incr nargs -1 ; set a($nargs) "pow($a($nargs),$a($s))" } } proc doFuncall {} { uplevel 1 { #puts nargs=$nargs set s $nargs; incr nargs -1 ; set a($nargs) "$a($nargs)($a($s))"} } proc doPrefix {} { uplevel 1 { if { "$x" == "PRE_MINUS" } { set a($nargs) "-$a($nargs)" } } } proc doConditional { } { set x [uplevel 1 set x] if { "$x" == "?" } { return } # must be : uplevel 1 { set s $nargs ; incr nargs -2 ; set a($nargs) "($a($nargs) ? $a([expr {$nargs + 1}]) : $a($s))" } } # #----------------------------------------------------------------- # # parseFromSuffixList -- takes a token list, and turns # it into a suffix form. eg: 1 + 2 - 3 ^ 4 --> 1 2 + 3 4 ^ - # Results: # # Side Effects: # #---------------------------------------------------------------- # proc parseFromSuffixList { list } { global getOp set stack "" set lim [llength $list] set i 0 set nargs 0 while { $i < $lim } { set x [lindex $list $i ] set bp [binding_power $x] incr i # all binary if { [llength $x] > 1 } { set a([incr nargs]) [lindex $x 1] } else { $getOp($x) } } return $a(1) } # #----------------------------------------------------------------- # # parseConvert -- given an EXPRESSION, parse it and find out # what are the variables, and convert a^b to pow(a,b). If # -variables "x y" is given, then x and y will be replaced by $x $y # doall 1 is giv # Results: # # Side Effects: # #---------------------------------------------------------------- # global Parser set Parser(convertOptions) { { doall 0 "convert all variables x to \$x" } { variables "" "list of variables to change from x to \$x" } } proc parseConvert { expr args } { global Parser getOptions $Parser(convertOptions) $args if { "$expr" == "" } { return [list {} {}] } set parselist [parseToSuffixLists "$expr;"] #puts "parselist=$parselist" catch { unset allvars } set new "" set answers "" foreach lis $parselist { foreach v $lis { if { ("[lindex $v 0]" == "id") && ([llength $v] == 2) && ([lsearch $Parser(reserved) [set w [lindex $v 1]]] < 0) } { if { ($doall != 0) || ([lsearch $variables $w] >= 0) } { append new " {id \$$w}" set allvars(\$$w) 1 } else { set allvars($w) 1 append new " {$v}" } } else { if { [llength $v] > 1 } { append new " {$v}" } else { append new " $v" } } } #puts "new=$new" append answers "[list [parseFromSuffixList $new]] " set new "" } return [list $answers [array names allvars]] } proc test { s } { set me [parseFromSuffixList [lindex [parseToSuffixLists "$s;"] 0]] puts $me return "[eval expr $s] [eval expr $me]" } ## endsource parse.tcl --- NEW FILE: Private.tcl --- ###### private.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ # a private way of storing variables on a window by window # basis proc makeLocal { win args } { foreach v $args { uplevel 1 set $v \[oget $win $v\] } } proc linkLocal { win args } { foreach v $args { uplevel 1 upvar #0 _WinInfo${win}\($v) $v } } proc clearLocal { win } { global _WinInfo$win # puts "clearing info for $win in [info level 1]" catch { unset _WinInfo$win } } proc oset { win var val } { global _WinInfo$win set _WinInfo[set win]($var) $val } proc oarraySet { win vals } { global _WinInfo$win array set _WinInfo$win $vals } proc oloc { win var } { return _WinInfo[set win]($var) } proc oarray { win } { return _WinInfo[set win] } proc oget { win var } { global _WinInfo$win return [set _WinInfo[set win]($var)] } ## endsource private.tcl |