Posted to tcl by mjanssen at Thu Oct 08 12:47:12 GMT 2020view raw

  1. proc tokenize {script} {
  2. #puts [lindex [info level 0] 0]
  3. set ctxt(rest) [split $script {}]
  4. set ctxt(parsed) {}
  5. set ctxt(currentCmd) {}
  6. while {$ctxt(rest) ne {}} {
  7. tokenizeCommentOrCommand ctxt
  8. }
  9. return $ctxt(parsed)
  10. }
  11.  
  12. proc handleContinuation {ctxtVar} {
  13.  
  14. upvar $ctxtVar ctxt
  15. lassign $ctxt(rest) char next
  16. if {$char eq "\\" && $next eq "\n"} {
  17. #puts [lindex [info level 0] 0]
  18. lset ctxt(rest) 1 " "
  19. set ctxt(rest) [lrange $ctxt(rest) 1 end]
  20. dropSpace ctxt
  21. }
  22. }
  23.  
  24. proc dropSpace {ctxtVar} {
  25. #puts [lindex [info level 0] 0]
  26. upvar $ctxtVar ctxt
  27. while {1} {
  28. set new [lassign $ctxt(rest) char]
  29. if {[string is space $char] && $char ne {}} {
  30. set ctxt(rest) $new
  31. continue
  32. }
  33. break
  34. }
  35. }
  36.  
  37. proc tokenizeCommentOrCommand {ctxtVar} {
  38. #puts [lindex [info level 0] 0]
  39. upvar $ctxtVar ctxt
  40. # parray ctxt
  41. while {1} {
  42. dropSpace ctxt
  43. handleContinuation ctxt
  44. lassign $ctxt(rest) char
  45. if {$char eq "#"} {
  46. tokenizeComment ctxt
  47. } else {
  48. tokenizeCommand ctxt
  49. }
  50. return
  51. }
  52. }
  53.  
  54. proc tokenizeComment {ctxtVar} {
  55. #puts [lindex [info level 0] 0]
  56. upvar $ctxtVar ctxt
  57. set comment {}
  58. while {1} {
  59. handleContinuation ctxt
  60. set ctxt(rest) [lassign $ctxt(rest) char]
  61. if {$char eq "\n" || $char eq {}} {
  62. lappend ctxt(parsed) [list "#" $comment]
  63. return
  64. }
  65. append comment $char
  66. }
  67. }
  68.  
  69.  
  70. proc tokenizeWord {ctxtVar} {
  71. #puts [lindex [info level 0] 0]
  72. upvar $ctxtVar ctxt
  73.  
  74. set word {}
  75.  
  76. # expand ?
  77. if {[join [lrange $ctxt(rest) 0 3] {}] eq "{*}" && ![string is space [lindex $ctxt(rest) 4]]} {
  78. append word "{*}"
  79. set ctxt(rest) [lrange $ctxt(rest) 0 3]
  80. }
  81. if {[string is space [lindex $ctxt(rest) 0 ]]} {
  82. error "Unexpected space at start of word"
  83. }
  84. set ctxt(rest) [lassign $ctxt(rest) char]
  85. append word $char
  86. switch -exact $char {
  87. "\{" {append word [tokenizeBraceWord ctxt]}
  88. "\"" {append word [tokenizeQuoteWord ctxt]}
  89. "\[" {append word [tokenizeSubstWord ctxt]}
  90. default {append word [tokenizeBareWord ctxt]}
  91. }
  92. lappend ctxt(currentCmd) $word
  93.  
  94. }
  95.  
  96. proc tokenizeCommand {ctxtVar} {
  97. #puts [lindex [info level 0] 0]
  98. upvar $ctxtVar ctxt
  99. # parray ctxt
  100. set ctxt(currentCmd) {}
  101. set word {}
  102. while {1} {
  103. set new [lassign $ctxt(rest) char]
  104. if {$char eq "\n" || $char eq {}} {
  105. if {[llength $ctxt(currentCmd)] > 0} {
  106. lappend ctxt(parsed) [list cmd {*}$ctxt(currentCmd)]
  107. }
  108. set ctxt(rest) $new
  109. return
  110. }
  111. dropSpace ctxt
  112. handleContinuation ctxt
  113. tokenizeWord ctxt
  114. }
  115. }
  116.  
  117. proc tokenizeQuoteWord {ctxtVar} {
  118. #puts [lindex [info level 0] 0]
  119. upvar $ctxtVar ctxt
  120. set word {}
  121. while {1} {
  122. handleContinuation ctxt
  123. set ctxt(rest) [lassign $ctxt(rest) char]
  124. append word $char
  125. if {$char eq "\\"} {
  126. set ctxt(rest) [lassign $ctxt(rest) char]
  127. append word $char
  128. continue
  129. }
  130. if {$char eq "\""} {
  131. break
  132. }
  133. }
  134. return $word
  135. }
  136.  
  137. proc tokenizeBraceWord {ctxtVar} {
  138. #puts [lindex [info level 0] 0]
  139. upvar $ctxtVar ctxt
  140. set word {}
  141. while {1} {
  142. handleContinuation ctxt
  143. set ctxt(rest) [lassign $ctxt(rest) char]
  144. append word $char
  145. if {$char eq "\\"} {
  146. set ctxt(rest) [lassign $ctxt(rest) char]
  147. append word $char
  148. continue
  149. }
  150. if {$char eq "\{"} {
  151. append word [tokenizeBraceWord ctxt]
  152. continue
  153. }
  154. if {$char eq "\}"} {
  155. break
  156. }
  157. }
  158. return $word
  159. }
  160.  
  161. proc tokenizeSubstWord {ctxtVar} {
  162. #puts [lindex [info level 0] 0]
  163. upvar $ctxtVar ctxt
  164. set word {}
  165. while {1} {
  166. handleContinuation ctxt
  167. set ctxt(rest) [lassign $ctxt(rest) char]
  168. append word $char
  169. if {$char eq "\\"} {
  170. set ctxt(rest) [lassign $ctxt(rest) char]
  171. append word $char
  172. continue
  173. }
  174. if {$char eq "\["} {
  175. append word [tokenizeSubstWord ctxt]
  176. continue
  177. }
  178. if {$char eq "\]"} {
  179. break
  180. }
  181.  
  182. }
  183. return $word
  184. }
  185.  
  186. proc tokenizeBareWord {ctxtVar} {
  187. #puts [lindex [info level 0] 0]
  188. upvar $ctxtVar ctxt
  189. set word {}
  190. while {1} {
  191. handleContinuation ctxt
  192. set ctxt(rest) [lassign $ctxt(rest) char]
  193. append word $char
  194. if {$char eq "\\"} {
  195. set ctxt(rest) [lassign $ctxt(rest) char]
  196. append word $char
  197. continue
  198. }
  199. if {$char eq "\["} {
  200. append word [tokenizeSubstWord ctxt]
  201. continue
  202. }
  203. if {[string is space $char]} {
  204. break
  205. }
  206. }
  207. return [string trimright $word]
  208. }