Updated 2013-03-05 02:04:39 by pooryorick

Summary  edit

Richard Suchenwirth: This is part 3 of the series that began with Playing APL and APLish - a partial parser apl2t that converts a string in sub-APL to a string that can be eval'ed by Tcl (call apl).

It is partial in two ways: it does not attempt to build a complete parse tree, and it does not cover more than a tiny subset of APL, but some already:
% apl2t {N N rho 1,N rho 0}
rho "$N $N" [, "1" [rho "$N" "0" ]]
% set N 5
5
% apl {N N rho 1,N rho 0}
1 0 0 0 0
0 1 0 0 0
0 0 1 0 0
0 0 0 1 0
0 0 0 0 1
% apl N+2*0.5
6.414213562373095

Still a lot to do (quoted strings, compound operators like -:..), but it's tremendous fun...;-)
namespace eval APL {
    namespace export apl apl2t

    proc apl s {uplevel [apl2t $s]}

    proc apl2t list {
    set res ""
    #---------- insert potential blanks everywhere, then reduce
    set list [join [split $list ""] \x81]
    foreach i {1 2} {
        regsub -all "(\[_A-Z0-9\])\x81(\[_A-Z0-9\])" $list {\1\2} list
        regsub -all "(\[a-z0-9\])\x81(\[a-z0-9\])" $list {\1\2} list
    }
    regsub -all "(\[.\])\x81(\[0-9\])" $list {\1\2} list
    regsub -all "(\[0-9\])\x81(\[.\])" $list {\1\2} list
    regsub -all \x81 $list " " list
    set op ""
    set last ""
    #---------- walk the list from back
    for {set n [llength $list]} {$n>0} {incr n -1} {
        set it [lindex $list [expr $n-1]]
        if [regexp {^[A-Z_]} $it] {
        if {$last!="val"} {set it "$it\""}
        set res "\$$it $res"
        set last val
        } elseif {[regexp {^-?[0-9.]} $it]} {
        if {$last!="val"} {set it $it\"}
        set res "$it $res"
        set last val
        } elseif {$it==")"} {
        if {$last=="val"} {set res \"$res}
        set last embed
        set open [lsearch $list "("]
        if {$open<0} {error "unmatched paren"}
        set embed [lrange $list [incr open] [incr n -2]]
        set res "\[[apl2t $embed]\] $res"
        set n $open
        } else {
        if {$last=="val"} {set res \"$res}
        set last op
        if [llength $op] {
            set res "$op $res"; set op ""
            if {$n>2} {set res "\[$res\]"}
        }
        set op $it
        }
    }
    if {$last=="val"} {set res \"$res}
    if [llength $op] {set res "$op $res"}
    set res
    }
}