Posted to tcl by evilotto at Wed Nov 27 22:31:57 GMT 2013view raw

  1. proc shift {lv} {
  2. upvar #1 $lv l
  3. set rv [lindex $l 0]
  4. set l [lrange $l 1 end]
  5. return $rv
  6. }
  7.  
  8. set fdefs [dict create]
  9.  
  10. proc fdef {w} {
  11. if {[dict exists $::fdefs $w]} {
  12. return [dict get $::fdefs $w inst]
  13. } else {
  14. return ""
  15. }
  16. }
  17.  
  18. proc farg {w} {
  19. if {[dict exists $::fdefs $w]} {
  20. return [dict get $::fdefs $w ac]
  21. } else {
  22. return 0
  23. }
  24. }
  25.  
  26. proc fdefine {w inst {ac 0}} {
  27. dict set ::fdefs $w inst $inst
  28. dict set ::fdefs $w ac $ac
  29. }
  30.  
  31. proc fasm {fsc} {
  32. set wl [split $fsc]
  33. set rs ""
  34. while {[llength $wl] > 0} {
  35. set w [shift wl]
  36. if {[string is entier $w]} {
  37. append rs "push $w;\n"
  38. } elseif {[fdef $w] ne ""} {
  39. append rs "[fdef $w] "
  40. for {set a 0} {$a < [farg $w]} {incr a} {
  41. append rs "[shift wl] "
  42. }
  43. append rs ";\n"
  44. } else {
  45. error "undefined word $w"
  46. }
  47. }
  48. return $rs
  49. }
  50.  
  51. fdefine + add
  52.  
  53. set fcode {1 2 +}
  54.  
  55. puts [fasm $fcode]
  56.  
  57. puts [::tcl::unsupported::assemble [fasm $fcode]]