# -*- 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