You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
285 lines
8.0 KiB
285 lines
8.0 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application calc676 0.1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval calc676 { |
|
# Tcl version of a Calc command for TIP 676. |
|
# |
|
# Prototype for an expression evaluator which does no internal substitution, |
|
# instead expecting any substitutions on its arguments to have been done |
|
# in advance by the usual Tcl mechanisms. To avoid unpleasant surprises |
|
# as warned about by Peter Da Silva, each token must be supplied as a |
|
# separate argument, e.g. calc 2 * abs( $x - $y ) NOT calc 2*abs($x-$y) |
|
# Only numeric and boolean values and operations are supported as there |
|
# is no way to distinguish arbitrary string values from operators they |
|
# might happen to mimic. |
|
|
|
variable tokens |
|
variable tokpos |
|
variable depth |
|
|
|
proc calc args { |
|
variable tokens |
|
variable tokpos |
|
variable depth |
|
|
|
if {[llength $args] == 0} {error "Calc: nothing to calculate"} |
|
set tokens $args |
|
set tokpos 0 |
|
set depth 0 |
|
set code [parse 0] |
|
#puts "GENERATED CODE:\n$code" |
|
set result [::tcl::unsupported::assemble $code] |
|
#puts "OUTPUT = '$result'" |
|
return $result |
|
} |
|
|
|
# Pratt Parser loosely based on https://www.rosettacode.org/wiki/Arithmetic_evaluation#Nim |
|
|
|
variable inprec |
|
variable incode |
|
|
|
# Define infix operators, their precedences and bytecodes |
|
foreach {op prec code} { |
|
) 0 - |
|
, 0 - |
|
? 1 - |
|
: 1 - |
|
|| 2 lor |
|
&& 3 land |
|
| 4 bitor |
|
^ 5 bitxor |
|
& 6 bitand |
|
== 7 eq |
|
!= 7 neq |
|
< 8 lt |
|
> 8 gt |
|
<= 8 le |
|
>= 8 ge |
|
<< 9 lshift |
|
>> 9 rshift |
|
+ 10 add |
|
- 10 sub |
|
* 11 mult |
|
/ 11 div |
|
% 11 mod |
|
** 12 expon |
|
} { |
|
set inprec($op) $prec |
|
set incode($op) $code |
|
} |
|
|
|
variable precode |
|
# Define prefix operators and their bytecodes |
|
foreach {op code} { |
|
+ uplus |
|
- uminus |
|
! not |
|
~ bitnot |
|
} { |
|
set precode($op) $code |
|
} |
|
variable preprec |
|
|
|
# Prefix ops all have the same precedence |
|
set preprec 13 |
|
|
|
# Parse expression until we hit an operator with precedence lower than min_prec. |
|
# The expression is supplied as a list of tokens in the global var tokens. |
|
# The current position in the input is in global var tokpos. |
|
# Returns the TAL bytecode to evaluate the expression. |
|
proc parse min_prec { |
|
variable inprec |
|
variable incode |
|
variable tokens |
|
variable tokpos |
|
variable depth |
|
|
|
set token [lindex $tokens $tokpos] |
|
set dep [incr depth] |
|
#puts "[string repeat { } $dep]PARSE min_prec=$min_prec tokpos=$tokpos token='$token'" |
|
incr tokpos |
|
set opcodes [parsePrefix $token] |
|
set depth $dep |
|
|
|
while {$tokpos < [llength $tokens]} { |
|
|
|
set token [lindex $tokens $tokpos] |
|
if {[info exists inprec($token)]} { |
|
set tok_prec $inprec($token) |
|
} else { |
|
error "Calc: expected operator but found '$token'" |
|
} |
|
#puts "[string repeat { } $dep]PARSE token=$token tok_prec=$tok_prec" |
|
if {$tok_prec < $min_prec} { |
|
break |
|
} |
|
# Binary ops are left-associative except for ** |
|
if {$tok_prec == $min_prec && $token ne "**"} { |
|
break |
|
} |
|
# if-then-else needs special handling |
|
incr tokpos |
|
if {$token eq "?"} { |
|
append opcodes [parseTernary] |
|
continue |
|
} |
|
# Infix operator |
|
append opcodes [parse $tok_prec] "$incode($token); " |
|
} |
|
#puts "[string repeat { } $dep]PARSE opcodes='$opcodes'" |
|
set depth [expr {$dep - 1}] |
|
return $opcodes |
|
} |
|
|
|
# Parse expression up to the first operator at the same level of parentheses. |
|
# Returns the bytecode to evaluate the subexpression. |
|
proc parsePrefix token { |
|
variable preprec |
|
variable precode |
|
variable tokens |
|
variable tokpos |
|
variable depth |
|
|
|
set dep [incr depth] |
|
#puts "[string repeat { } $dep]PARSEPREFIX token=`$token` tokpos=$tokpos" |
|
|
|
# Is it a number? In C would use Tcl_GetNumberFromObj() here |
|
if {[string is entier $token] || [string is double $token]} { |
|
return "push $token; " |
|
} |
|
# Is it boolean? In C would use Tcl_GetBoolean() here |
|
if {[string is boolean $token]} { |
|
return "push $token; " |
|
} |
|
# Parenthesised subexpression? |
|
if {$token eq "("} { |
|
set opcodes [parse 0] |
|
set token [lindex $tokens $tokpos] |
|
if {$token eq ")"} { |
|
incr tokpos |
|
return $opcodes |
|
} |
|
error "Calc: expected ')' but found '$token'" |
|
} |
|
# Unary operator? |
|
if {$token in {+ - ! ~}} { |
|
return "[parse $preprec]$precode($token); " |
|
} |
|
# Function call? |
|
if {[regexp {^([[:alpha:]]+)\($} $token - name]} { |
|
set fun [namespace which tcl::mathfunc::$name] |
|
if {$fun ne {}} { |
|
set opcodes "push $fun; " |
|
append opcodes [parseFuncArgs] |
|
return $opcodes |
|
} |
|
} |
|
error "Calc: expected start of expression but found '$token'" |
|
} |
|
|
|
# Parse zero or more arguments to a math function. The arguments are |
|
# expressions separated by commas and terminated by a closing parenthesis. |
|
# Returns the bytecode to evaluate the arguments and call the function. |
|
proc parseFuncArgs {} { |
|
variable tokens |
|
variable depth |
|
variable tokpos |
|
|
|
set dep [incr depth] |
|
#puts "[string repeat { } $dep]PARSEFUNCARGS tokpos=$tokpos" |
|
|
|
set token [lindex $tokens $tokpos] |
|
set arg_num 1 |
|
while 1 { |
|
if {$token eq ")"} { |
|
incr tokpos |
|
append opcodes "invokeStk $arg_num; " |
|
return $opcodes |
|
} |
|
append opcodes [parse 0] |
|
incr arg_num |
|
|
|
set token [lindex $tokens $tokpos] |
|
switch $token { |
|
, { incr tokpos } |
|
) {} |
|
default { |
|
error "Calc: expected ')' or ',' but found '$token'" |
|
} |
|
} |
|
} |
|
} |
|
|
|
# We have just seen the '?' of an if-then-else, so parse the rest of that. |
|
# Returns the bytecode to check the previous condition, then evaluate the |
|
# appropriate branch. |
|
proc parseTernary {} { |
|
variable inprec |
|
variable tokens |
|
variable tokpos |
|
variable depth |
|
|
|
set dep [incr depth] |
|
#puts "[string repeat { } $dep]PARSETERNARY tokpos=$tokpos" |
|
|
|
set else else[incr ::labelcount] |
|
set end end$::labelcount |
|
append opcodes "jumpFalse $else; [parse $inprec(:)]" |
|
|
|
set token [lindex $tokens $tokpos] |
|
if {$token ne ":"} { |
|
error "Calc: expected ':' but found '$token'" |
|
} |
|
incr tokpos |
|
|
|
append opcodes "jump $end; label $else; [parse $inprec(:)]" |
|
append opcodes "label $end; nop; " |
|
return $opcodes |
|
} |
|
|
|
|
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide calc676 [namespace eval calc676 { |
|
variable version |
|
set version 0.1.0 |
|
}] |
|
return |