├── LICENSE.txt
├── README.md
├── TclForth.command
└── source
    ├── chess.fth
    ├── compiler.tcl
    ├── console.fth
    ├── forth.fth
    ├── tfmain.tcl
    └── tk.fth


/LICENSE.txt:
--------------------------------------------------------------------------------
 1 | The TclForth source is provided under the MIT license. 
 2 | Additional licenses apply, see below.
 3 | 
 4 | The MIT License (MIT)
 5 | 
 6 | Copyright © 2015  Wolf Wejgaard
 7 | 
 8 | Permission is hereby granted, free of charge, to any person obtaining a copy
 9 | of this software and associated documentation files (the "Software"), to deal
10 | in the Software without restriction, including without limitation the rights
11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
12 | copies of the Software, and to permit persons to whom the Software is
13 | furnished to do so, subject to the following conditions:
14 | 
15 | The above copyright notice and this permission notice shall be included in
16 | all copies or substantial portions of the Software.
17 | 
18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
24 | THE SOFTWARE.
25 | 
26 | ---
27 | 
28 | The TclForth system releases are based on: 
29 | 
30 | The Tcl/Tk runtime system: http://www.tcl.tk/software/tcltk/license.html
31 | 
32 | The Metakit database: http://equi4.com/metakit/license.html
33 | 
34 | 
35 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # TclForth
 2 | 
 3 | A multi-platform desktop Forth system based on Tcl/Tk.  
 4 | 
 5 | ### Overview
 6 | TclForth uses Tcl as its native language. The Forth code and colon words are compiled to Tcl procedures that pass arguments and results on a stack. The stack items are handled as local variables. The Forth and Tcl procedures coexist in the Tcl namespace and are all taken care of by the Tcl runtime system. Thus, the Tcl bytecode interpreter is also the inner interpreter of TclForth. For details see http://wiki.tcl.tk/37199.
 7 | 
 8 | I have built applications with TclForth for a while and release it as an open source project. The system is prepared as self-contained double-click executables for Windows and OS-X (starpacks) and as a set of source files for Tcl in Linux and elsewhere. Installation = unzip. 
 9 | 
10 | ### Features
11 | 
12 | * Universal desktop Forth 
13 | * A TclForth program runs unchanged in Windows, OS-X, Linux, and more
14 | * Native data types array, string, list, and dict
15 | * Native local variables
16 | * Native graphical toolkit based on Tk
17 | * Native database (Metakit)
18 | * Desktop apps for Windows and OS-X
19 | 
20 | ### [Guide / Wiki](https://github.com/wejgaard/tclforth/wiki)
21 | TclForth is special. Explore a new Forth universe.
22 | 
23 | ### [Comments](https://github.com/wejgaard/tclforth/issues) 
24 | Use the Issues for Comments, Questions, Ideas. 
25 | 
26 | ### UPDATE 64-bit: see https://github.com/wejgaard/HolonCode/tree/master/HolonTF
27 | 
28 | ### [Release v0.7.0](https://github.com/wolfwejgaard/tclforth/releases) 
29 | 
30 | The **TclForth.zip** archive contains the source files as well as Tcl executables for Windows and OS-X, and shell code for Linux.
31 | 
32 | * Windows: Run tclforth.exe
33 | * OS-X: Run tclforth.app
34 | * Linux: Run tclforthx in a terminal. In the Tcl console:
35 | 
36 | ```
37 |     cd <source-directory>
38 |     source tfmain.tcl
39 | ```
40 | 
41 | ### Example Application ChessMoves Game
42 | Included with the release.
43 | 
44 | ![Image of Holon86](https://www.holonforth.com/images/tclforth-chess.jpg)
45 | 
46 | 
47 | 
48 | 


--------------------------------------------------------------------------------
/TclForth.command:
--------------------------------------------------------------------------------
1 | cd ~/documents/Github/TclForth/source
2 | tclsh tfmain.tcl


--------------------------------------------------------------------------------
/source/chess.fth:
--------------------------------------------------------------------------------
  1 | \ File:    chess.fth
  2 | \ Project: TclForth
  3 | \ Version: 0.56
  4 | \ License: Tcl
  5 | \ Author:  Wolf Wejgaard
  6 | \  
  7 | \ A Forth version of Richard Suchenwirth's Chess in Tcl -- http://wiki.tcl.tk/4070
  8 | \
  9 | 
 10 | \ ===================================================================================
 11 | \ Model
 12 | \ ===================================================================================
 13 | 
 14 | {} array board
 15 | 
 16 | {} list history
 17 | 
 18 | "white" string toMove
 19 | 
 20 | : reset { | setup i x y -- }
 21 | 	cast setup list
 22 | 	{r n b q k b n r
 23 | 	 p p p p p p p p
 24 | 	 . . . . . . . .
 25 | 	 . . . . . . . .
 26 | 	 . . . . . . . .
 27 | 	 . . . . . . . .
 28 | 	 P P P P P P P P
 29 | 	 R N B Q K B N R} 
 30 | 	setup setlist	
 31 | 	0 i set
 32 | 	{8 7 6 5 4 3 2 1} {y} foreach	
 33 | 		{A B C D E F G H} {x} foreach
 34 | 			i setup "$x$y" board set  
 35 | 			i incr
 36 | 		repeat	
 37 | 	repeat
 38 | 	"white" toMove set 	
 39 | 	{} history setlist ;
 40 | 
 41 | : color { c -- color }	
 42 | 	c ascii 97 < if "white" else "black" then color set ;
 43 | 
 44 | Code sameSide? { a b -- f }  
 45 | 	set f [regexp {[a-z][a-z]|[A-Z][A-Z]} $a$b]
 46 | 
 47 | "white" variable side
 48 | 
 49 | : coords { square -- x y }  
 50 | 	{} square split y set ascii 64 - x set ;
 51 | 
 52 | : square { x y -- sq } 	
 53 | 	x 64 + char x set "$x$y" sq set ;
 54 | 
 55 | : valid? { move | from to fromMan toMan x y x0 y0 x1 y1 dx dy adx ady -- result } 
 56 | 	"-" move split to set from set
 57 | 	to {} = if 0 return then
 58 | 	from board fromMan set to board toMan set
 59 | 	fromMan color toMove != if 0 return then
 60 | 	fromMan toMan sameSide? if 0 return then
 61 | 	from coords y0 set x0 set  to coords y1 set x1 set
 62 | 	x1 x0 - dup dx set abs adx set  y1 y0 - dup dy set abs ady set
 63 | 	fromMan tolower "n" !=  adx not ady not or adx ady = or  and 
 64 | 	if	x0 x set  y0 y set
 65 | 		begin x x1 != y y1 != or while 
 66 | 			x x0 != y y0 != or 	
 67 | 			x y square board "." != and 
 68 | 			if 0 return then   \ planned path is blocked
 69 | 			dx sgn x add  dy sgn y add
 70 | 		repeat
 71 | 	then
 72 | 	fromMan tolower case
 73 | 		k of adx 2 < ady 2 < and return endof
 74 | 		q of adx 0= ady 0= or adx ady = or return endof
 75 | 		b of adx ady = return endof
 76 | 		n of adx 1 = ady 2 = and adx 2 = ady 1 = and or return endof
 77 | 		r of adx 0= ady 0= or return endof
 78 | 	endcase
 79 | 	fromMan case
 80 | 		P of y0 2 = dy 2 = and  dy 1 = or  dx 0= toMan "." = and  and
 81 | 			adx 1 = ady 1 = and "p" toMan sameSide? and  or return endof
 82 | 		p of y0 7 = dy -2 = and dy -1 = or  dx 0= toMan "." = and  and
 83 | 			adx 1 = ady 1 = and "P" toMan sameSide? and  or return endof
 84 | 	endcase 
 85 | 	0 result set ;
 86 | 
 87 | : validMoves { from | to move victim -- result }
 88 | 	cast move string cast result list 
 89 | 	{} result setlist
 90 | 	board names {to} foreach
 91 | 		"$from-$to" move set
 92 | 		move valid? if
 93 | 			to board victim set
 94 | 			"-$victim" move append 
 95 | 			move result append
 96 | 		then
 97 | 	repeat
 98 | 	result sort ;
 99 | 
100 | {k king q queen b bishop n knight r rook p pawn} array Name
101 | 
102 | {k 0 q 9 b 3.2 n 3 r 5 p 1 . 0} array Value
103 | 
104 | : values { | square man whitesum blacksum -- result }
105 | 	board names {square} foreach
106 | 		square board  man set
107 | 		man tolower Value 
108 | 		man color "white" = if whitesum add else blacksum add then
109 | 	repeat
110 | 	"w:$whitesum  b:$blacksum " result set ;
111 | 
112 | \ ===================================================================================
113 | \ View
114 | \ ===================================================================================
115 | 
116 | : Chessboard { -- }
117 | 	".t" "toplevel" Widget top
118 | 	"Chess in Forth" top title
119 | 	"? {console show}" top bind
120 | 	"<Escape> exit" top bind 
121 | 	"$::top.c" Canvas w 
122 | 	"-height 300 -width 300" w config
123 | 	"-fill both -expand 1" w pack
124 | 	"$::top.f" "frame" Widget frame 
125 | ;
126 | 
127 | 0 variable info
128 | 
129 | Code Panel { -- }
130 | 	label  $::frame.e -width 30 -anchor w -textvar info -relief sunken
131 | 	button $::frame.u -text Undo  -command {undo; drawSetup}
132 | 	button $::frame.r -text Reset -command {reset; drawSetup}
133 | 	button $::frame.f -text Flip  -command {flipSides}
134 | 	eval pack [winfo children $::frame] -side left -fill both
135 | 	pack $::frame -fill x -side bottom
136 | 	trace add variable ::toMove write doMoveInfo 
137 | 	set ::info "white to move"
138 | 
139 | 0 variable X
140 | 
141 | 0 variable Y
142 | 
143 | {#ffd39b #6e8b3d} list cColors
144 | 
145 | : manPolygon { man -- shape }
146 | 	man tolower case
147 | 	b of {-10 8 -5 5 -9 0 -6 -6 0 -10 6 -6 9 0 5 5 10 8 6 10 0 6 -6 10} endof
148 | 	k of {-8 10 -10 1 -3 -1 -3 -3 -6 -3 -6 -7 -3 -7 -3 -10
149 | 			3 -10 3 -7 6 -7 6 -3 3 -3 3 -1 10 1 8 10} endof
150 | 	n of {-8 10 -1 -1 -7 0 -10 -4 0 -10 6 -10 10 10} endof
151 | 	p of {-8 10 -8 7 -5 7 -2 -1 -4 -5 -2 -10 2 -10 4 -5 2 -1 5 7 8 7 8 10} endof
152 | 	r of {-10 10 -7 1 -10 0 -10 -10 -5 -10 -5 -6 -3 -6 -3 -10
153 |    			3 -10 3 -6 5 -6 5 -10 10 -10 10 0 7 1 10 10} endof
154 | 	q of {-6 10 -10 -10 -3 0 0 -10 3 0 10 -10 6 10} endof
155 | 	endcase shape set ;
156 | 
157 | 35 variable sqw
158 | 
159 | : center { x0 y0 x1 y1 -- xc yc }  
160 | 	x0 x1 + 2/ xc set  y0 y1 + 2/ yc set ;
161 | 
162 | : drawMan { where what -- } 
163 | 	what "." = if return then
164 | 	what manPolygon  
165 | 	what uppercase? if "white" "black" else "black" "gray" then 
166 | 	"mv @$where" w polygon
167 | 	"@$where" 0 0 sqw 0.035 * dup w scale
168 | 	"@$where" "$where"	w bbox center  w move ;
169 | 
170 | : drag { x y -- }  
171 | 	"current" x X - y Y - w move  x X set y Y set  ;
172 | 
173 | : bindBoard { -- }
174 | 	{<Configure> drawBoard} w bind  
175 | 	{mv <1> "push $::w; push %x; push %y; click"} w bindtag
176 | 	{mv <B1-Motion> "push %x; push %y; drag"} w bindtag
177 | 	{mv <ButtonRelease-1> "push %x; push %y; release"} w bindtag ;
178 | 
179 | : drawSetup { | x y -- }
180 | 	"mv" w delete
181 | 	9 1 do 9 1 do
182 | 		I y set J 64 + char x set "$x$y" dup board drawMan
183 | 	loop loop ;
184 | 
185 | : drawBoard { | x0 x y rows row cols col cIndex tag -- }
186 | 	cast rows list  
187 | 	cast cols list
188 | 	w windowExists if "all" w delete then
189 | 	15 x0 set  x0 x set  5 y set  0 cIndex set 35 sqw set
190 | 	{8 7 6 5 4 3 2 1} rows setlist 	{A B C D E F G H} cols setlist
191 | 	side "white" != if rows revert cols revert then
192 | 	rows getlist {row} foreach
193 | 	 	7 y sqw 2/ + row w text
194 | 		cols getlist {col} foreach
195 | 			x y  sqw x add  x y sqw + cIndex cColors "square $col$row" w rectangle
196 | 			1 cIndex - cIndex set 
197 | 		repeat
198 | 		x0 x set sqw y add 
199 | 		1 cIndex - cIndex set 
200 | 	repeat
201 | 	x0 sqw 2/ - x set
202 | 	8 y add  \ letters go below chess board
203 | 	cols getlist {col} foreach sqw x add  x y col w text repeat
204 | 	drawSetup ;
205 | 
206 | : drawChess { -- }  
207 | 	Chessboard Panel w bindBoard reset drawBoard ;
208 | 
209 | \ ===================================================================================
210 | \ Control
211 | \ ===================================================================================
212 | 
213 | : moveInfo { -- }  
214 | 	"$::toMove to move - [values; pop]" info set ;
215 | 
216 | \ Need procedure to accept the three arguments for a trace command. The arguments are not used here. 
217 | \ Note: The colon word moveInfo is called in a Tcl proc. 
218 | proc doMoveInfo {- - -} {moveInfo}
219 | 
220 | Code getFrom { w -- from }  
221 | 	$w raise current
222 | 	regexp {@(..)} [$w gettags current] -> from
223 | 
224 | 0 variable From
225 | 
226 | : click { w cx cy | move victim to fill newfill -- }
227 | 	cx X set  cy Y set
228 | 	w getFrom From set 
229 | 	From validMoves {move} foreach
230 | 		"-" move split victim set to set drop
231 | 		w to "-fill" ItemGet fill set
232 | 		fill "green" !=  fill "red" != and if
233 | 			victim "." = if "green" else "red" then newfill set
234 | 			w to "-fill" newfill ItemPut
235 | 			"$w itemconfigure $to -fill $fill" 1000 doafter
236 | 		then 
237 | 	repeat ;
238 | 
239 | : moveMan { move | to from FromMan -- ToMan }
240 | 	cast move string
241 | 	"-" move split  to set  from set
242 | 	from board FromMan set  to board ToMan set
243 | 	"-$ToMan" move append 
244 | 	FromMan to board set  "." from board set
245 | 	move history append
246 | 	toMove "white" = if "black" else "white" then toMove set ;
247 | 
248 | : distance { xa ya xb yb -- xd yd }  
249 | 	xa xb - xd set  ya yb - yd set  ;
250 | 
251 | : release { cx cy | to item tags victim target -- }
252 | 	cast tags list
253 | 	{} to set
254 | 	"overlap $cx $cy $cx $cy" w find {item} foreach
255 | 		item w gettags tags setlist   
256 | 		"square" tags search 0 >=	if tags pop to set break	then
257 | 	repeat
258 | 	"$::From-$to" valid? if  
259 | 		"$::From-$to" moveMan victim set  
260 | 		victim tolower "k" = if "Checkmate" info set  then
261 | 		"@$to" w delete
262 | 		"@$::From" "current" w dtag
263 | 		"@$to" "withtag" "current" w addtag
264 | 		to target set
265 | 	else From target set  \ go back on invalid move
266 | 	then
267 | 	"current"  target w bbox center  "current" w bbox center  distance  w move  ;
268 | 
269 | : undo { | from to hit -- }
270 | 	history length 0= if return then
271 | 	"-"  history pop split  hit set  to set  from set
272 | 	to board  from board  set
273 | 	hit {} = if "." else hit then to board set
274 | 	toMove "white" = if "black" else "white" then  toMove set ;
275 | 
276 | : flipSides { -- }
277 | 	"all" w delete
278 | 	side "white" = if "black" else "white" then side set
279 | 	drawBoard ;
280 | 
281 | drawChess
282 | 
283 | 


--------------------------------------------------------------------------------
/source/compiler.tcl:
--------------------------------------------------------------------------------
  1 | # File:    compiler.tcl
  2 | # Project: TclForth
  3 | # Version: 0.6.0
  4 | # License: Tcl
  5 | # Author:  Wolf Wejgaard  
  6 | # 
  7 | 
  8 | set comp(text) {}   ;# source text of the unit
  9 | set comp(code) {}   ;# compiled tcl code
 10 | set comp(word) {}   ;# currently compiled word/item
 11 | set comp(i) 0       ;# current index in source text
 12 | set comp(end) 0     ;# end of source text
 13 | set comp(in) {}     ;# input parameters tcl code
 14 | set comp(out) {}    ;# output parameters tcl code
 15 | set comp(prev) 0    ;# saved current index
 16 | set comp(imm) 0     ;# start of imm code
 17 | set comp(icode) {}  ;# imm code
 18 | 
 19 | proc GetItem {} {
 20 | 	global comp
 21 | 	if {$comp(i)>=$comp(end)} {set comp(word) "" ; return $comp(word)}
 22 | 	set reg [regexp -indices -start $comp(i)  {\S+} $comp(text) range]
 23 | # if $reg==0 {set comp(word) "", return $comp(word)} 
 24 | 	set start [lindex $range 0]
 25 | 	set end [lindex $range 1]
 26 | 	set comp(word) [string range $comp(text) $start $end ] 
 27 | 	set comp(prev) $start
 28 | 	incr end; 	set comp(i) $end
 29 | 	if {$comp(word)=="."} {set comp(word) ".."}
 30 | 	return $comp(word)
 31 | }
 32 | 
 33 | proc EmptyLine {} {
 34 | 	global f line
 35 | 	gets $f line
 36 | 	while {[string first {\ } $line]==0 || [string first {#} $line]==0} {gets $f line}
 37 | 	set line [string trim $line]
 38 | 	expr {$line==""}
 39 | }
 40 | 
 41 | # Next program unit. 
 42 | # A unit is a block of source text terminated by an empty line
 43 | proc GetUnit {} {
 44 | 	global f line comp
 45 | 	while {[EmptyLine]&&[eof $f]==0} {}
 46 | 	set code $line	
 47 | 	while { ![EmptyLine]  && [eof $f]==0} {
 48 | 		set code $code\n$line
 49 | 	}
 50 | 	set comp(text) $code
 51 | 	set comp(end) [string length $comp(text)]
 52 | 	set comp(i) 0
 53 | }
 54 | 
 55 | # Forth word list array
 56 | # For each name the entry contains the corresponding compile code 
 57 | set words(name) code
 58 | 
 59 | proc MakeProc {} {
 60 | 	global comp 
 61 | 	set comp(code) $comp(text) 
 62 | 	uplevel #0 {eval $comp(text)}
 63 | }
 64 | 
 65 | # Creates a Forth proc that receives and passes its arguments on the data stack. 
 66 | proc MakeCode {} {
 67 | 	global comp words
 68 | 	set comp(name) [GetItem] 
 69 | 	set comp(code) "proc $comp(name) \{\} \{ "
 70 | 	CompileStack
 71 | 	if {$comp(in)!=""} {append comp(code) "\n$comp(in) "}
 72 | 	append comp(code) [string range $comp(text) $comp(i) $comp(end)]
 73 | 	append comp(code) " \n$comp(out) \} "
 74 | 	set words($comp(name))  "CompWord $comp(name)"
 75 | 	eval $comp(code)
 76 | }
 77 | 
 78 | proc MakeCompiler {} {
 79 | 	global comp words
 80 | 	GetItem
 81 | 	set comptext [string range $comp(text) $comp(i) $comp(end)]
 82 | 	set words($comp(word)) [string trimleft $comptext]
 83 | }
 84 | 
 85 | proc MakeColon {} {
 86 | 	global comp words
 87 | 	set comp(name) [GetItem]
 88 | 	set words($comp(name))  "CompWord $comp(name)"
 89 | 	set comp(code) "proc $comp(name) \{\} \{\n"
 90 | 	CompileStack
 91 | 	if {$comp(in)!=""} {append comp(code) "$comp(in) \n"}
 92 | 	GetItem
 93 | 	CompileColon	
 94 | 	append comp(code) " $comp(out) \n\} "
 95 | 	eval $comp(code)
 96 | }
 97 | 
 98 | proc EvalTcl {} {
 99 | 	global comp
100 | 	incr comp(i)
101 | 	set comp(code) [string range $comp(text) $comp(i) $comp(end)]
102 | 	uplevel #0 {eval $comp(code)}
103 | }
104 | 
105 | # Interprets = compiles and executes a Forth script
106 | proc EvalForth {} {
107 | 	global comp words
108 | 	set comp(i) 0
109 | 	GetItem
110 | 	CompileColon	
111 | 	uplevel #0 {eval $comp(code)}
112 | }
113 | 
114 | # Called by Forth word "
115 | proc PushText {} {
116 | 	global comp 
117 | 	set start $comp(i); incr start
118 | 	set end [string first {"} $comp(text) $start]
119 | 	if {$end<0} {error "String not finished"}
120 | 	incr end -1 
121 | 	set text [string range $comp(text) $start $end]
122 | 	incr end 2; set comp(i) $end
123 | 	append comp(code) "push \"$text\" ; "
124 | }
125 | 
126 | # Called by Forth word { 
127 | proc PushList {} {
128 | 	global comp 
129 | 	set start $comp(i)
130 | 	set end [string first \} $comp(text) $start]
131 | 	if {$end<0} {error "List not finished"}
132 | 	incr start; incr end -1 
133 | 	set text [string range $comp(text) $start $end]
134 | 	incr end 2; set comp(i) $end
135 | 	append comp(code) "push \{$text\}  ; "
136 | }
137 | 
138 | proc SkipLine {} {
139 | 	global comp
140 | 	set eol [string first \n $comp(text) $comp(i)]
141 | 	if $eol>0 {
142 | 		incr eol; 	set comp(i) $eol
143 | 	} {
144 | 		set comp(i) $comp(end)
145 | 	}
146 | }
147 | 
148 | proc SkipComment {} {
149 | 	global comp
150 | 	set eoc [string first ) $comp(text) $comp(i)]
151 | 	if $eoc>0 {
152 | 		incr eoc; 	set comp(i) $eoc
153 | 	} {
154 | 		set comp(i) $comp(end)
155 | 	}
156 | }
157 | 
158 | # Compile action of code and colon words
159 | proc CompWord {name} {
160 | 	global comp
161 | 	append comp(code) " $name ; " 
162 | }
163 | 
164 | # Compile action of most compiler=immediate words
165 | proc appendcode {code} {
166 | 	global comp
167 | 	append comp(code) $code
168 | }
169 | 
170 | # Called by definer objecttype.
171 | # Creates an objecttype array. 
172 | # The indices are messages, the values are method scripts.
173 | # Example use:
174 | # objecttype Variable
175 | # 		get  {push $obj}	
176 | #		set  {set obj [pop]} 
177 | #		... 
178 | proc MakeObjecttype {} {
179 | 	global comp words 
180 | 	set objtype [GetItem] 
181 | 	set words($objtype)  "MakeObject ::$objtype"	
182 | 	set comp(code) "array set $objtype  {"
183 | 	append comp(code) [string range $comp(text) $comp(i) $comp(end)]
184 | 	append comp(code) " }"
185 | 	uplevel #0 {eval $comp(code)}
186 | }
187 | 
188 | # Creates an instance of objtype.
189 | proc MakeObject {objtype} {
190 | 	global comp words
191 | 	set object [GetItem] ;# name of object
192 | 	set words($object) "CompObject $objtype"	
193 | 	if {[array names $objtype -exact instance]!=""} {
194 | 		AppendObjectCode $object [set ${objtype}(instance)]
195 | 	} {
196 | 		AppendObjectCode $object {set obj {} ; }
197 | 	}
198 | }
199 | 
200 | # If the following source item is a message of objecttype type
201 | # the corresponding method script is appended,
202 | # else the default method {} is used.
203 | proc AppendMethod {object type} {
204 | 	global comp words
205 | 	if [isLocal $object] { } {set object "::$object"}			
206 | 	set comp(prev) $comp(i); 
207 | 	set message [GetItem]
208 | 	if [info exists ::${type}($message)] {
209 | 		set method [set ::${type}($message)]
210 | 	} {
211 | 		set message ""
212 | 		set method [set ::${type}($message)]
213 | 		set comp(i) $comp(prev)	
214 | 	}
215 | 	AppendObjectCode $object $method
216 | }
217 | 
218 | proc CompObject {objtype} {	
219 | 	global comp
220 | 	AppendMethod $comp(word) $objtype
221 | }
222 | 
223 | # Replaces the dummy "obj" in the appended method code by 
224 | # the current object's name
225 | proc AppendObjectCode {object method} {
226 | 	global comp 
227 | 	set code [string map "obj $object" $method]
228 | 	append comp(code) "$code ; "
229 | }
230 | 
231 | # Handles the Forth stack diagram { in1 .. | local1 .. -- out1 .. }
232 | # Accepts short form {} and {--} for empty diagrams
233 | proc CompileStack {} {
234 | 	global comp locals
235 | 	array unset locals   
236 | 	set comp(in) {} ; set comp(out) {} ; set stackvar true
237 | 	GetItem
238 | 	if {$comp(word)=="\{\}"} return
239 | 	if {$comp(word)=="\{--\}"} return
240 | 	if {$comp(word)!="\{"} {error "stack diagram missing"}  
241 | 	GetItem 
242 | 	while {$comp(word) != "--"} {
243 | 		if {$comp(word)=="\}"} {error "stack error: missing '--'"}
244 | 		if {$comp(word)==""} {error "stack error: missing '--'"}
245 | 		if {$comp(word)=="|"} {set stackvar false; GetItem; continue} 
246 | 		if $stackvar {
247 | 			set comp(in) [linsert $comp(in) 0 "set $comp(word) \[pop\] ; "]
248 | 		} {
249 | 			set comp(in) [lappend comp(in) "set $comp(word) 0 ; "] 
250 | 		}
251 | 		set locals($comp(word)) {variable}
252 | 		GetItem
253 | 	}
254 | 	GetItem 
255 | 	while {$comp(word) != "\}" } {
256 | 		if {$comp(word)==""} {error "stack error: missing '\}'"}
257 | 		set comp(out) [lappend comp(out) "push \$$comp(word) ; "] 
258 | 		set locals($comp(word)) {variable}
259 | 		GetItem
260 | 	}
261 | 	set comp(in) [join $comp(in)]
262 | 	set comp(out) [join $comp(out)]
263 | }
264 | 
265 | # Returns true if word is a number (int, double, decimal, octal, hex)
266 | proc isNumber {word} {	
267 | 	return [expr [string is integer -strict $word]||[string is double -strict $word]]
268 | }
269 | 
270 | proc isLocal {word} {
271 | 	global locals
272 | 	expr {[array names locals -exact $word]!=""}
273 | }
274 | 
275 | proc isString {} {
276 | 	global comp
277 | 	if {[string first {"} $comp(word)]==0} {
278 | 		set comp(i) $comp(prev); PushText
279 | 		return 1
280 | 	} {
281 | 		return 0
282 | 	}
283 | }
284 | 
285 | proc isList {} {
286 | 	global comp
287 | 	if {[string first \{ $comp(word)]==0} {
288 | 		set comp(i) $comp(prev); PushList
289 | 		return 1
290 | 	} {
291 | 		return 0
292 | 	}
293 | }
294 | 
295 | proc CompileColon {} {
296 | 	global comp lcname locals words 
297 | 	while {$comp(word) != "" } {
298 | 		if [isLocal $comp(word)] {
299 | 			set object $comp(word);  
300 | 			set type $locals($object)
301 | 			AppendMethod $object ::$type
302 | 		}  {
303 | 			if [info exists words($comp(word))] {
304 | 				uplevel #0 {eval $words($comp(word))}			
305 | 			} else {
306 | 				if [isNumber $comp(word)] {
307 | 					append comp(code) "push $comp(word) ; "
308 | 				} {
309 | 					if {![isString]&&![isList]} {ShowCompCode; error "$comp(word) is undefined"; }
310 | 				}
311 | 			}
312 | 		}
313 | 		GetItem 
314 | 	}
315 | }
316 | 
317 | # To be overwritten in Forth Console
318 | proc ShowCompCode {} {
319 | 	puts $::comp(code)
320 | }
321 | 
322 | proc SetupInterpreter {} {
323 | 	global comp view locals doi doj dok 
324 | 	array unset locals
325 | 	set doi 0; set doj -1; set dok -2  
326 | 	set comp(code) {}; set comp(objtype) {}
327 | }
328 | 
329 | proc InterpretText {} {
330 | 	global definer  
331 | 	SetupInterpreter
332 | 	set definer [string tolower [ GetItem ]]
333 | 	switch $definer {
334 | 		proc MakeProc
335 | 		tcl EvalTcl
336 | 		compiler MakeCompiler
337 | 		immediate MakeCompiler
338 | 		code MakeCode
339 | 		:  MakeColon
340 | 		objecttype MakeObjecttype
341 | 		datatype MakeObjecttype
342 | 		default EvalForth
343 | 	}
344 | }
345 | 
346 | proc LoadUnit {} {
347 | 	InterpretText
348 | 	puts $::comp(code)\n
349 | }
350 | 
351 | proc LoadForth {file} {
352 | 	global f
353 | 	set f [open $file r]; 	fconfigure $f -encoding binary
354 | 	while {[eof $f]==0} { 	
355 | 		GetUnit
356 | 		LoadUnit
357 | 	}
358 | 	close $f
359 | }
360 | 
361 | # Print vectors, will be redefined for output to the console widget.
362 | proc print {text} {
363 | 	puts -nonewline $text
364 | }
365 | 
366 | proc printnl {text} {
367 | 	puts $text
368 | }
369 | 
370 | proc osx {} {
371 | 	if {$::tcl_platform(os)=="Darwin"} {return true} {return false}
372 | }
373 | 
374 | set MonitorFile ./holon.mon
375 | 
376 | proc LastAccess {} {
377 | 	global MonitorFile
378 | 	if {[file exists $MonitorFile]} {
379 | 		file stat $MonitorFile status
380 | 		return $status(mtime)
381 | 	} {
382 | 		return 0
383 | 	}
384 | }
385 | 
386 | set LastRead 0
387 | 
388 | proc Monitor {} {
389 | 	global LastRead errorInfo
390 | 	if {$LastRead != [LastAccess]} {
391 | 		set LastRead [LastAccess]
392 | 		if {[catch DoIt result]} {
393 | 			puts "Error: $errorInfo"
394 | 		}
395 | 	}
396 | 	after 200 Monitor
397 | }
398 | 
399 | proc LoadInConsole {file} {
400 | 	global f Console comstart montext
401 | 	set f [open $file r]; 	fconfigure $f -encoding binary
402 | 	$Console insert $comstart [read $f]
403 | 	close $f
404 | }
405 | 
406 | proc DoIt {} {
407 | 	global MonitorFile
408 | 	set result [uplevel #0 {eval { LoadInConsole $MonitorFile}}]
409 | #	puts $result
410 | #	SendMonitor $result
411 | 	EvalText
412 | }
413 | 
414 | proc SendMonitor {text} {
415 | 	set f [open $::MonitorFile w]
416 | 	fconfigure $f -encoding binary
417 | 	puts $f "$text\n"
418 | 	close $f
419 | }
420 | 
421 | proc StartMonitor {} {
422 | 	global LastRead
423 | 	set LastRead [LastAccess]
424 | 	Monitor
425 | }
426 | 
427 | proc PrintMontext {} {
428 | 	global montext
429 | 	printnl $montext
430 | }
431 | 
432 | 


--------------------------------------------------------------------------------
/source/console.fth:
--------------------------------------------------------------------------------
  1 | \ File:    console.fth
  2 | \ Project: TclForth
  3 | \ Version: 0.6.0
  4 | \ License: Tcl
  5 | \ Author:  Wolf Wejgaard
  6 | \
  7 | 
  8 | : ConsoleWindows  { -- }
  9 | 	"TclForth Version 0.7.0" Title
 10 | 	".forth" "text" Widget Console
 11 | 	"-padx 10 -pady 10 -relief sunken -border 1 -highlightcolor white" Console config   
 12 | 	"-expand 1 -fill both" Console pack
 13 | 	".code" "text" Widget CodeWindow
 14 | 	"-height 6 -pady 10 -padx 10 -relief sunken -border 1 -highlightcolor white" CodeWindow config  
 15 | \	"-expand 0 -fill both" CodeWindow pack
 16 | ;
 17 | 
 18 | \ ===================================================================================
 19 | \ Print to Forth console
 20 | \ ===================================================================================
 21 | 
 22 | proc print-fth {text} {
 23 | 	$::Console insert end $text
 24 | }
 25 | 
 26 | proc printnl-fth {text} {
 27 | 	$::Console insert end "$text\n"
 28 | }
 29 | 
 30 | Code printforth { -- }  
 31 | 	if {[info procs print-fth]==""} {return}
 32 | 	rename print print-tcl
 33 | 	rename print-fth print
 34 | 	rename printnl printnl-tcl
 35 | 	rename printnl-fth printnl
 36 | 
 37 | \ ===================================================================================
 38 | \ Menus
 39 | \ ===================================================================================
 40 | 
 41 | Code ImportTcl {} 
 42 | 	set file [tk_getOpenFile -filetypes {{"" {".tcl"}}} -initialdir ./]
 43 | 	if {$file==""} {return}
 44 | 	source $file
 45 | 
 46 | Code ImportForth {} 
 47 | 	set file [tk_getOpenFile -filetypes {{"" {".fth"}}} -initialdir ./]
 48 | 	if {$file==""} {return}
 49 | 	LoadForth $file
 50 | 
 51 | : FileMenu { -- } 
 52 | 	".menubar.file" Menu fMenu
 53 | 	"File" fMenu Menubar addmenu
 54 | 	"Load .tcl" "ImportTcl" fMenu addcommand
 55 | 	"Load .fth" "ImportForth" fMenu addcommand
 56 | ;
 57 | 
 58 | : SetupMenu {}
 59 | 	".menubar.setup" Menu sMenu
 60 | 	"Setup" sMenu Menubar addmenu
 61 | 	"Clear Console" {ClearConsole; okprompt}	sMenu addcommand
 62 | 	"Show stack" {set withStack 1; cr; okprompt } sMenu addcommand
 63 | 	"Hide stack" {set withStack 0; cr; okprompt } sMenu addcommand
 64 | 	"Show Codewindow" {pack $CodeWindow -expand 0 -fill both} sMenu addcommand
 65 | 	"Hide Codewindow" {pack forget $CodeWindow} sMenu addcommand
 66 | 	"Open Tcl console" {catch "console show"} sMenu addcommand
 67 | 
 68 | Code GetWords { -- fwords } 
 69 | 	set fwords [array names ::words]
 70 | 
 71 | : ShowWords  { | words -- }
 72 | 	cast words list
 73 | 	GetWords	words setlist  
 74 |  	words sort words join
 75 | 	cr words print 
 76 | ;
 77 | 
 78 | Tcl bind . <Control-w> {ShowWords; okprompt}
 79 | 
 80 | Code openURL { webadr -- } 
 81 |      if {$::tcl_platform(os)=="Darwin"} {
 82 |           eval exec open $webadr &
 83 |      } {
 84 |           eval exec [auto_execok start] $webadr &
 85 |      }
 86 | 
 87 | : HelpMenu {} 
 88 | 	".menubar.help" Menu hMenu
 89 | 	"Help" hMenu Menubar addmenu
 90 | 	"TclForth Words" {ShowWords; okprompt} hMenu addcommand
 91 | 	"TclForth Guide" {push "https://github.com/wolfwejgaard/tclforth/wiki"; openURL} hMenu addcommand
 92 | 	"Tcl Commands" {push "http://www.tcl.tk/man/tcl/TclCmd/contents.htm"; openURL} hMenu addcommand
 93 | 
 94 | : ConsoleMenu {}  
 95 | 	FileMenu 
 96 | 	SetupMenu
 97 | 	HelpMenu
 98 | 
 99 | \ ===================================================================================
100 | \ Command history
101 | \ ===================================================================================
102 | 
103 | {} list comhistory
104 | 
105 | 0 variable comindex
106 | 
107 | 1.0 variable comstart
108 | 
109 | : SaveComline { comline -- } 
110 | 	comline "" != 
111 | 	if	comline comhistory append  	
112 | 		comhistory length comindex set 	
113 | 	then
114 | ;
115 | 
116 | : ShowComline { comline -- }
117 | 	comstart Console end  Console delete
118 | 	comline Console append
119 | 	1.0 Console yview
120 | ;
121 | 
122 | : PrevComline { -- }  
123 | 	comindex 0> if -1 comindex add then 
124 | 	comindex comhistory	ShowComline
125 | ;
126 | 
127 | : NextComline { -- }
128 | 	comindex incr
129 | 	comindex comhistory  length >= 
130 | 	if   comhistory length  comindex set   ""
131 | 	else comindex comhistory 
132 | 	then	ShowComline
133 | ;
134 | 
135 | \ ===================================================================================
136 | \ Command line interpreter
137 | \ ===================================================================================
138 | 
139 | 1 variable withStack
140 | 
141 | : ShowStack { -- } 
142 | 	1 withStack set
143 | ;
144 | 
145 | : HideStack { -- }
146 | 	0 withStack set
147 | ;
148 | 
149 | : okprompt { -- }
150 | 	depth 0> withStack and
151 | 	if   "($::stack) ok\n" 
152 | 	else "ok\n" 
153 | 	then Console append update 
154 | 	Console insert comstart set
155 | 	1.0 Console yview
156 | ;
157 | 
158 | \ ===================================================================================
159 | \ Forth Console
160 | \ ===================================================================================
161 | 
162 | Code ShowCompCode { -- }
163 | 	global comp
164 | 	$::CodeWindow insert end $comp(code)\n
165 | 
166 | Code LoadLine { -- } 
167 | 	InterpretText
168 | 	ShowCompCode
169 | 
170 | Code EvalUnit {}
171 | 	global comp unit errorInfo
172 | 	set unit [string trim $unit]; 
173 | 	push $unit; SaveComline
174 | 	set comp(text) $unit; set comp(i) 0; set comp(end) [string length $comp(text)]
175 | 	if [catch LoadLine err]  {printnl "? $err"}
176 | #	if [catch LoadLine]  {print $errorInfo}
177 | 
178 | Code EvalText { -- }  
179 | 	global comp unit
180 | 	set text [$::Console get "$::comstart -1 chars" "insert lineend"]; 
181 | 	set text [string trim $text]; set textend [string length $text]
182 | 	if {$text== ""} {okprompt; return}
183 | 	set lines [split $text \n]
184 | 	set unit ""
185 | 	printnl ""
186 | 	$::CodeWindow delete 1.0 end
187 | 	foreach line $lines {
188 | 		if {$line != ""} {
189 | 			append unit \n $line 
190 | 		} {
191 | 			EvalUnit
192 | 			set unit ""
193 | 		}
194 | 	}
195 | 	EvalUnit
196 | 	okprompt
197 | 
198 | : ClearConsole { -- }
199 | 	!s
200 | 	"1.0" Console end Console delete ;
201 | 
202 | Tcl bind . <Control-c> {ClearConsole; okprompt}
203 | 
204 | : ClearStack { -- }
205 | 	!s cr okprompt ;
206 | 	
207 | Tcl bind . <Control-s> ClearStack
208 | 
209 | Code HideTclConsole { -- }
210 | 	catch {console hide}
211 | 
212 | : ForthConsole { -- }
213 | 	HideTclConsole
214 | 	ConsoleWindows
215 | 	"<Return> {EvalText; break}" Console bind   
216 | 	"<Shift-Return> {cr; break}" Console bind       
217 | 	"<Up> {PrevComline; break}"  Console bind
218 | 	"<Down> {NextComline; break}" Console bind
219 | 	ConsoleMenu
220 | 	printforth
221 | 	"Ctrl-C = Clear Console" .cr
222 | 	"Ctrl-S = Clear Stack" .cr
223 | 	"Ctrl-W = Show Words" .cr
224 | 	"--" .cr 	
225 | 	okprompt
226 | ;
227 | 
228 | 


--------------------------------------------------------------------------------
/source/forth.fth:
--------------------------------------------------------------------------------
  1 | Compiler \  SkipLine
  2 | 
  3 | \ File:    forth.fth
  4 | \ Project: TclForth
  5 | \ Version: 0.6.0
  6 | \ License: Tcl
  7 | \ Author:  Wolf Wejgaard
  8 | \ 
  9 | 
 10 | \ ===================================================================================
 11 | \ Comments
 12 | \ ===================================================================================
 13 | 
 14 | Compiler (  SkipComment
 15 | 
 16 | # this is a Tcl comment line 
 17 | \ this is a Forth comment line
 18 | ( this is a Forth comment )
 19 | 
 20 | \ Code definitions are delimited by an empty line.
 21 | \ end-code is optional
 22 | Compiler end-code
 23 | 
 24 | \ Colon definitions are delimited by an empty line.
 25 | \ A semicolon is optional
 26 | Compiler ;
 27 | 
 28 | \ ===================================================================================
 29 | \ Parameter Stack
 30 | \ ===================================================================================
 31 | 
 32 | # The parameter stack is a list
 33 | Tcl set stack {}
 34 | 
 35 | proc pop {} {
 36 | 	if {[llength $::stack]==0} {error "stack underflow"}
 37 | 	set r [lindex $::stack end]; set ::stack [lreplace $::stack end end]
 38 | 	return $r 
 39 | }
 40 | 
 41 | proc push {p} {
 42 | 	lappend ::stack $p
 43 | }
 44 | 
 45 | Code .s { -- }  
 46 | 	printnl $::stack
 47 | 
 48 | Code !s { -- }  
 49 | 	set ::stack ""
 50 | 
 51 | \ Most stack handling words are defined already by their stack diagrams.
 52 | \ E.g. dup { n -- n n }  is compiled to proc dup {} {set n [pop]; push $n;  push $n; }
 53 | 
 54 | Code dup { n -- n n }
 55 | 
 56 | Code swap { n1 n2 -- n2 n1 }
 57 | 
 58 | Code over { n1 n2 -- n1 n2 n1 }
 59 | 
 60 | Code drop { n1 -- }
 61 | 
 62 | Code nip { n1 n2 -- n2 }
 63 | 
 64 | Code rot { n1 n2 n3 -- n2 n3 n1 }
 65 | 
 66 | Code depth { -- n }
 67 | 	set n [llength $::stack]
 68 | 
 69 | \ ===================================================================================
 70 | \ Arithmetic
 71 | \ ===================================================================================
 72 | 
 73 | Code + { n1 n2 -- n3 } 
 74 | 	set n3 [expr {$n1+$n2}]
 75 | 
 76 | Code 1+ { n1 -- n2 }
 77 | 	set n2 [incr n1]
 78 | 
 79 | Code 1- { n1 -- n2 } 
 80 | 	set n2 [incr n1 -1]
 81 | 
 82 | Code - { n1 n2 -- n3 }
 83 | 	set n3 [expr {$n1-$n2}]
 84 | 
 85 | Code * { n1 n2 -- n3 } 
 86 | 	set n3 [expr {$n1*$n2}]
 87 | 
 88 | Code / { n1 n2 -- n3 } 
 89 | 	set n3 [expr {$n1/$n2}]
 90 | 
 91 | Code 2/ { n1 -- n2 }  
 92 | 	set n2 [expr {$n1/2}]
 93 | 
 94 | Code % { n1 n2 -- n3 }  
 95 | 	set n3 [expr {$n1%$n2}]
 96 | 
 97 | Code mod { n1 n2 -- n3 }  
 98 | 	set n3 [expr {$n1%$n2}]
 99 | 
100 | Code int { n1 -- n2 } 
101 | 	set n2 [expr int($n1)]
102 | 
103 | Code min { n1 n2 -- n } 
104 | 	if {$n1<$n2} {set n $n1} {set n $n2}
105 | 
106 | Code max { n1 n2 -- n } 
107 | 	if {$n1>$n2} {set n $n1} {set n $n2}
108 | 
109 | Code abs { n1 -- n2 }  
110 | 	set n2 [expr abs($n1)]
111 | 
112 | Code sgn { n1 -- n2 }  
113 | 	set n2 [expr {$n1>0? 1: $n1<0? -1: 0}]
114 | 
115 | \ ===================================================================================
116 | \ Logic and Comparison
117 | \ ===================================================================================
118 | 
119 | Code or { n1 n2 -- n3 }
120 | 	set n3 [expr $n1 || $n2]
121 | 
122 | Code and { n1 n2 -- n3 } 
123 | 	set n3 [expr $n1 && $n2]
124 | 
125 | Code not { n1 -- n2 }  
126 | 	set n2 [expr {!$n1}]
127 | 
128 | Code == { n1 n2 -- flag }  
129 | 	set flag [expr {$n1==$n2}]
130 | 
131 | Code = { n1 n2 -- flag }  
132 | 	set flag [expr {$n1==$n2}]
133 | 
134 | Code >= { n1 n2 -- flag }  
135 | 	set flag [expr {$n1>=$n2}]
136 | 
137 | Code <= { n1 n2 -- flag } 
138 | 	set flag [expr {$n1<=$n2}]
139 | 
140 | Code < { n1 n2 -- flag }  
141 | 	set flag [expr {$n1<$n2}]
142 | 
143 | Code > { n1 n2 -- flag }  
144 | 	set flag [expr {$n1>$n2}]
145 | 
146 | Code != { n1 n2 -- flag } 
147 | 	set flag [expr {$n1!=$n2}]
148 | 
149 | Code <> { n1 n2 -- flag }  
150 | 	set flag [expr {$n1!=$n2}]
151 | 
152 | Code 0= { n1 -- flag }  
153 | 	set flag [expr {$n1==0}]
154 | 
155 | Code 0< { n1 -- flag } 
156 | 	set flag [expr {$n1<0}]
157 | 
158 | Code 0> { n -- flag }
159 | 	set flag [expr {$n>0}]
160 | 
161 | \ ===================================================================================
162 | \ Math Functions -- to be extended, Tcl has all you need
163 | \ ===================================================================================
164 | 
165 | Code sqrt { n1 -- n2 } 
166 | 	set n2 [expr sqrt($n1)]
167 | 
168 | \ ===================================================================================
169 | \ String and List Operators
170 | \ ===================================================================================
171 | 
172 | \ Puts empty data {} on the stack. 
173 | Compiler ""  
174 | 	appendcode "push \"\" ; "
175 | 
176 | Code endchar { s -- c }
177 | 	set c [string index $s end]
178 | 
179 | Code tolower { C -- c }  
180 | 	set c [string tolower $C]
181 | 
182 | Compiler split 
183 | 	appendcode { foreach {j} [split [pop] [pop]] {push $j} ; }
184 | 
185 | Code uppercase? { c -- f }  
186 | 	set f [regexp {[A-Z]} $c]
187 | 
188 | Compiler [
189 | 	set comp(imm) [string length $comp(code)]
190 | 
191 | Compiler ]
192 | 	set comp(icode) [string range $comp(code) $comp(imm) [string length $comp(code)]]
193 | 	incr comp(imm) -1
194 | 	set comp(code) [string range $comp(code) 0 $comp(imm)]
195 | 	eval $::comp(icode)
196 | 
197 | Compiler {  PushList
198 | 
199 | Compiler {} 
200 | 	appendcode "push \{\} ; "
201 | 
202 | \ ===================================================================================
203 | \ Data Types  
204 | \ ===================================================================================
205 | 
206 | Objecttype constant  
207 | 	instance  {set obj [pop]}
208 | 	{}        {push $obj}
209 | 
210 | Objecttype variable  
211 | 	instance  {set obj [pop]}
212 | 	{}        {push $obj}
213 | 	get       {push $obj}
214 | 	@         {push $obj}
215 | 	set       {set obj [pop]}
216 | 	!         {set obj [pop]}
217 | 	incr      {incr obj}
218 | 	decr      {incr obj -1}
219 | 	add	      {set obj [expr {$obj+[pop]}]}
220 | 	print     {printnl $obj}
221 | 
222 | Objecttype array   
223 | 	instance  {array set obj [pop]}
224 | 	{}        {push $obj([pop])}
225 | 	get	      {push $obj([pop])}
226 | 	set       {set obj([pop]) [pop]}
227 | 	!         {set obj([pop]) [pop]}
228 | 	incr      {incr obj([pop])}
229 | 	add	      {incr obj([pop]) [pop]}
230 | 	print     {printnl $obj([pop])}
231 | 	names     {push [array names obj]}
232 | 
233 | Objecttype string   
234 | 	instance  {set obj [pop]}
235 | 	{}        {push $obj}
236 | 	set       {set obj [pop]}
237 | 	!         {set obj [pop]}
238 | 	index     {push [string index $obj [pop]]}
239 | 	range     {swap; push [string range $obj [pop] [pop]]}
240 | 	length    {push [string length $obj]}
241 | 	tolower   {push [string tolower $obj]}
242 | 	append    {append obj [pop]}
243 | 	print     {printnl $obj}
244 | 	first     {push [string first [pop] $obj]}
245 | 	hexdump   {binary scan $obj H* hex; printnl [regexp -all -inline .. $hex]}
246 | 
247 | proc @list {obj i} {
248 | 	push [lindex $obj $i]
249 | }
250 | 
251 | proc !list {obj i} {
252 | 	upvar #0 $obj object
253 | 	set object [lreplace $object $i $i [pop]]
254 | }
255 | 
256 | proc lrevert list {
257 | 	set res {}
258 | 	set i [llength $list]
259 | 	while {$i} {lappend res [lindex $list [incr i -1]]}
260 | 	return $res
261 |  }
262 | 
263 | Code end { list -- e }  
264 | 	set e [lindex $list end]
265 | 
266 | Objecttype list   
267 | 	instance  {set obj [pop]}
268 | 	{}        {@list $obj [pop]}  
269 | 	index     {@list $obj [pop]}
270 | 	set       {!list obj [pop]}  
271 | 	!         {!list obj [pop]}   
272 | 	getlist   {push $obj}  
273 | 	setlist   {set obj [pop]}  
274 | 	append    {lappend obj [pop]}
275 | 	push      {lappend obj [pop]}
276 | 	pop       {push [lindex $obj end]; set obj [lreplace $obj end end]}
277 | 	length    {push [llength $obj]}
278 | 	clear     {set obj ""}
279 | 	revert    {set obj [lrevert $obj]}
280 | 	sort      {set obj [lsort $obj]}
281 | 	join      {set obj [join $obj]}
282 | 	print     {printnl "{$obj}"} 
283 | 	search    {push [lsearch $obj [pop]]}
284 | 	last      {push [lindex $obj end]}
285 | 
286 | Objecttype file  
287 | 	instance  {set obj "[pop] handle" ; }
288 | 	{}        {@list $obj 1}   
289 | 	open-w    {push [open [lindex $obj 0] w]; !list obj 1 }
290 | 	open      {push [open [lindex $obj 0] r]; !list obj 1 }
291 | 	close     {close [lindex $obj 1]}
292 | 	put       {puts [lindex $obj 1] [pop]}
293 | 	get       {push [gets [lindex $obj 1]]}
294 | 	read      {push [read [lindex $obj 1]]}
295 | 	eof       {push [eof [lindex $obj 1]]}
296 | 
297 | \ use: cast <variable> <type>
298 | Compiler cast  
299 | 	set obj [GetItem]; set type [GetItem]
300 | 	if [isLocal $obj] {
301 | 		set locals($obj) $type
302 | 	} {
303 | 		error "only locals can be casted"
304 | 	}
305 | 
306 | \ ===================================================================================
307 | \ Flow Control
308 | \ ===================================================================================
309 | 
310 | Compiler if  
311 | 	appendcode "if \[pop\]  \{\n"
312 | 
313 | Compiler then  
314 | 	appendcode \}\n
315 | 
316 | Compiler else 
317 | 	appendcode 	"\} else \{\n"
318 | 
319 | Compiler case 
320 | 	appendcode "switch \[pop\]  \{\n"
321 | 	GetItem
322 | 	appendcode "$comp(word) "
323 | 
324 | Compiler of  
325 | 	appendcode "  \{ "
326 | 
327 | Compiler endof  
328 | 	appendcode " \}\n"
329 | 	GetItem
330 | 	if {$comp(word)!="endcase"} {
331 | 		appendcode "$comp(word) "
332 | 	} {
333 | 		appendcode "\}\n"
334 | 	}
335 | 
336 | Compiler endcase  
337 | 	appendcode " \}\} \n \n "
338 | 
339 | Compiler foreach 
340 | 	appendcode "foreach  \[pop\] \[pop\] \{\n"
341 | 
342 | Compiler exit  
343 | 	appendcode "return ; "
344 | 
345 | Compiler return  
346 | 	appendcode "return ; "
347 | 
348 | \ ===================================================================================
349 | \ Loops
350 | \ ===================================================================================
351 | 
352 | Compiler begin  
353 | 	appendcode "\nwhile 1 \{\n"
354 | 
355 | Compiler until  
356 | 	appendcode "\nif \[pop\] break \}\n "
357 | 
358 | Compiler while  
359 | 	appendcode "\nif \{\[pop\]==0\} break \n"
360 | 
361 | Compiler repeat  
362 | 	appendcode \}\n
363 | 
364 | Compiler again  
365 | 	appendcode \n\}\n
366 | 
367 | Compiler break  
368 | 	appendcode "break ; "
369 | 
370 | Compiler do  
371 | 	incr ::doi; incr ::doj; incr ::dok; 
372 | 	appendcode "set start$::doi \[pop\]; set limit$::doi \[pop\]; set incr$::doi 1
373 | 	for \{set _i$::doi \$start$::doi\} \{\$_i$::doi < \$limit$::doi \} \{incr _i$::doi \$incr$::doi  \} \{\n"
374 | 
375 | Compiler loop  
376 | 	incr ::doi -1; incr ::doj -1; incr ::dok -1; 
377 | 	appendcode "\}\n"
378 | 
379 | Compiler +loop  
380 | 	appendcode "set incr$::doi \[pop\]; \}\n"	
381 | 	incr ::doi -1; incr ::doj -1; incr ::dok -1;
382 | 
383 | Compiler I  
384 | 	appendcode "push \$_i$::doi; "
385 | 
386 | Compiler i  
387 | 	appendcode "push \$_i$::doi; "
388 | 
389 | Compiler J 
390 | 	appendcode "push \$_i$::doj; "
391 | 
392 | Compiler j
393 | 	appendcode "push \$_i$::doj; "
394 | 
395 | Compiler K
396 | 	appendcode "push \$_i$::dok; "
397 | 
398 | Compiler k 
399 | 	appendcode "push \$_i$::dok; "
400 | 
401 | Compiler leave 
402 | 	appendcode " break ;  "
403 | 
404 | \ use: n times ... repeat
405 | Compiler times
406 | 	incr ::doi; 
407 | 	appendcode "set limit$::doi \[pop\]; while \{\$limit$::doi>0\} \{incr limit$::doi -1; "
408 | 
409 | \ ===================================================================================
410 | \ Print
411 | \ ===================================================================================
412 | 
413 | Compiler ."  
414 | 	PushText ; appendcode "print \[pop\] ; "
415 | 
416 | \ Use . or .. - The compiler replaces . by .. with respect for Tk.
417 | Code .. { text -- }  
418 | 	print "$text "
419 | 
420 | Code cr { -- } 
421 | 	printnl ""
422 | 
423 | Code .cr { text -- }  
424 | 	printnl $text
425 | 
426 | Code space { -- }   
427 | 	print " "
428 | 
429 | : spaces { n -- } 
430 | 	n times space repeat
431 | ;
432 | 
433 | Code emit { a -- }  
434 | 	print  [format %c $a]
435 | 
436 | \ Example: "A" ascii  ( -- 65 )
437 | Code ascii { s -- a } 
438 | 	binary scan $s "c" a
439 | 
440 | \ Returns the ASCII value of the first char. 
441 | \ Example:  asciiOf cdefg  ( -- 99 ) 
442 | Compiler asciiOf  
443 | 	push [GetItem]; ascii;
444 | 
445 | \ Returns character c of ASCII value a 
446 | \ Example: 65 char ( -- A )
447 | Code char  { a -- c }  
448 | 	set c [format %c $a]
449 | 
450 | \ ===================================================================================
451 | \ Timing
452 | \ ===================================================================================
453 | 
454 | Compiler update  
455 | 	appendcode " update ; "
456 | 
457 | Compiler sleep  
458 | 	appendcode " after \[pop\] ;  "
459 | 
460 | Compiler wait  
461 | 	appendcode " after \[pop\] \{set _ 0\}; vwait _
462 | 
463 | Compiler doafter  
464 | 	appendcode " after \[pop\] \[pop\] ;  "
465 | 
466 | \ ===================================================================================
467 | \ Exceptions
468 | \ ===================================================================================
469 | 
470 | \ Use: catch <command>
471 | \ only single command, no list. 
472 | \ End catch with: "message" ErrorMsg 
473 | \ or with: error" message" 
474 | Compiler catch  
475 | 	GetItem
476 | 	appendcode "if \{\[catch $comp(word) result\]\} \{
477 | 	printnl \$result; 
478 | 	\}
479 | 	"
480 | 
481 | Compiler error"  
482 | 	PushText
483 | 	appendcode " error \[pop\] ; "
484 | 
485 | Code ErrorMsg { text -- }  
486 | 	error $text
487 | 
488 | Code alias { new old -- } 
489 | 	set ::words($new) "CompWord $old"
490 | 	end-code
491 | 
492 | Code tcleval { command -- }  
493 | 	eval $command
494 | 
495 | 


--------------------------------------------------------------------------------
/source/tfmain.tcl:
--------------------------------------------------------------------------------
 1 | # File:    tfmain.tcl
 2 | # Project: TclForth
 3 | # Version: 0.6.0
 4 | # License: Tcl
 5 | # Author:  Wolf Wejgaard  
 6 | # 
 7 | 
 8 | package require Tk
 9 | catch {console show}
10 | 
11 | source compiler.tcl
12 | 
13 | LoadForth forth.fth
14 | 
15 | LoadForth tk.fth
16 | 
17 | LoadForth console.fth
18 | 
19 | if [namespace exists starkit] {
20 | 	cd ../../
21 | 	if [osx] {cd ../../../}
22 | }
23 | StartMonitor
24 | ForthConsole
25 | 
26 | 


--------------------------------------------------------------------------------
/source/tk.fth:
--------------------------------------------------------------------------------
  1 | \ File:    tk.fth
  2 | \ Project: TclForth
  3 | \ Version: 0.6.0
  4 | \ License: Tcl
  5 | \ Author:  Wolf Wejgaard
  6 | \ 
  7 | 
  8 | tcl package require Tk
  9 | 
 10 | \ ===================================================================================
 11 | \ General Widgets
 12 | \ ===================================================================================
 13 | 
 14 | \ Use: ".tkname" "type" Widget Forthname
 15 | \ Example: ".forth" "text" Widget Console
 16 | Objecttype Widget 
 17 | 	instance   {uplevel #0 {set type [pop]; set obj [pop]; eval $type $obj}}
 18 | 	{}         {push $obj}
 19 | 	config     {eval $obj [concat configure [pop]]}
 20 | 	pack       {eval [concat pack $obj [pop]]}
 21 | 	bind       {eval [concat bind $obj [pop]]}
 22 | 	wait       {tkwait window $obj}
 23 | 	insert     {push [$obj index insert]}
 24 | 	append     {$obj insert end [pop] ; $obj mark set insert end}
 25 | 	delete     {swap ; $obj delete [pop] [pop]}
 26 | 	yview      {$obj yview moveto [pop]}
 27 | 	end        {push [$obj index "end -1 char"]}
 28 | 	title      {wm title $obj [pop]}
 29 | 	add        {eval $obj [concat add [pop]]}
 30 | 
 31 | \ ===================================================================================
 32 | \ Tk Menus
 33 | \ ===================================================================================
 34 | 
 35 | Objecttype Menu 
 36 | 	instance   {uplevel #0 {set obj [pop]; menu $obj}}
 37 | 	{}         {push $obj}
 38 | 	addcommand {$obj add command -command [pop] -label [pop]}
 39 | 	addmenu    {$obj add cascade -menu [pop] -label [pop]}
 40 | 
 41 | ".menubar" Menu Menubar
 42 | 
 43 | \ Anchor Menubar in console window
 44 | tcl . config -menu .menubar
 45 | 
 46 | \ ===================================================================================
 47 | \ Canvas
 48 | \ ===================================================================================
 49 | 
 50 | Code createPoly { w polygon color outline tag -- }  
 51 | 	$w create poly $polygon -fill $color -tag $tag -outline $outline
 52 | 
 53 | Code ItemGet { w tag field -- value }  
 54 | 	set value [$w itemcget $tag $field]
 55 | 
 56 | Code ItemPut { w tag field value -- }  
 57 | 	$w itemconfigure $tag $field $value
 58 | 
 59 | Code 3swap  { s1 s2 s3 -- s3 s2 s1 }
 60 | 
 61 | Code 4swap  { s1 s2 s3 s4 -- s4 s3 s2 s1 }
 62 | 
 63 | Code 5swap  { s1 s2 s3 s4 s5 -- s5 s4 s3 s2 s1 }
 64 | 
 65 | Code 6swap  { s1 s2 s3 s4 s5 s6 -- s6 s5 s4 s3 s2 s1 }
 66 | 
 67 | Code unlist { -- } set ::stack [join $::stack]
 68 | 
 69 | Objecttype Canvas  
 70 | 	instance   {uplevel #0 {set obj [pop]; canvas $obj} }
 71 | 	{}         {push $obj}
 72 | 	create     {eval $obj [concat create [pop]]}
 73 | 	text       {3swap; eval $obj [concat create text [pop] [pop] -text \"[pop]\"]}
 74 | 	config     {eval $obj [concat configure [pop]]}
 75 | 	set        {eval $obj [concat config [pop]]}
 76 | 	rectangle  {6swap;	eval $obj [concat create rect [pop] [pop] [pop] [pop] -fill [pop] -tag \"[pop]\"]} 
 77 | 	delete     {$obj delete [pop]}
 78 | 	polygon    {4swap;	eval $obj [concat create poly \{[pop]\} -fill [pop] -outline [pop] -tag \"[pop]\"]} 
 79 | 	scale      {5swap; eval $obj [concat scale \"[pop]\" [pop] [pop] [pop] [pop]]}
 80 | 	move       {3swap; eval $obj [concat move [pop] [pop] [pop]]}
 81 | 	bbox       {push [$obj bbox [pop]]; unlist}
 82 | 	pack       {eval [concat pack $obj [pop]]}
 83 | 	bind       {eval [concat bind $obj [pop]]}
 84 | 	bindtag    {eval [concat $obj bind [pop]]}
 85 | 	find       {push [eval $obj find [pop]]}
 86 | 	gettags    {push [eval $obj gettags [pop]]}
 87 | 	dtag       {$obj dtag [pop] [pop]}
 88 | 	addtag     {3swap; $obj addtag [pop] [pop] [pop]}
 89 | 
 90 | \ ===================================================================================
 91 | \ Other
 92 | \ ===================================================================================
 93 | 
 94 | Code windowExists { w -- flag }  
 95 | 	set flag [winfo exists $w]
 96 | 
 97 | \ Set title of main window
 98 | Code Title { text  -- }  
 99 | 	wm title . $text
100 | 
101 | 
102 | \ change 23.6.2020


--------------------------------------------------------------------------------