./version081/0040755000000000000000000000000007303263313011633 5ustar rootroot./version081/bcm550_source_pictures/0040700000000000000000000000000007303262475016122 5ustar rootroot./version081/datasheets/0040700000000000000000000000000007303262447013755 5ustar rootroot./version081/examples/0040700000000000000000000000000007300314375013441 5ustar rootroot./version081/examples/task.html0100777000000000000000000000331307300314375015307 0ustar rootroot COLDFORTH KERNEL 
 
	 
	ram_variable %counter
    #clock_low task: example
		BEGIN
			1 %counter +!
			xtest #10 xwait
		AGAIN
	;task

Start the task 

 
	
	\ all tasks are installed in the vocabulary &tasks
	ALSO &tasks 
	example taskin
	PREVIOUS
A task providing an interpeter 
 
	: test_print ( --)
		." a print" send
	;


	ram_variable %etube
	ram_variable %2depth
	#clock_low task: example2
		S" tube" R/W Sopen 
		DEPTH %2depth !
		DUP 'output_file !
	    DUP 'input_file !
	    DUP 'abort_file !
		%etube !
		['] prompt
		'abort !
		ABORT
	;task

Start the task 

 
	.( start task 2)
	\ all tasks are installed in the vocabulary &tasks
	ALSO &tasks 
	example2 taskin
	PREVIOUS
A task providing an interpeter DUAL PORT 
 
	ram_variable %ptube
	ram_variable xx
	#clock_low port_task: example3

		S" port_tube/$1F" R/W Sopen
  		

		DUP 'output_file !
	    DUP 'input_file !
	    DUP 'abort_file !
		%ptube !
		['] prompt
		'abort !
		ABORT
	;task
	 

 
	.( open the port_tube)
	R/W open port_tube/$1F
	close
	.( start taks 3)
	\ all tasks are installed in the vocabulary &tasks
	ALSO &tasks 
	example3 taskin
	PREVIOUS
./version081/heapmanagementpaper/0040755000000000000000000000000007303262432015636 5ustar rootroot./version081/heapmanagementpaper/abort_buffer.png0100777000000000000000000001501107300314366021007 0ustar rootrootPNG  IHDR wKPLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4DIDATx흍 F}9D Fтzt%)>pCՄjnVQpQpQPY7sh[ܾmGa(=Apu熿~-ޯ\G3H&R ~$A?mjtZ/S^ޚ(j4B7nO=`j`#3 V) g h51Mw4g%|,i==<7G, ' p f?N=Qca\^GaL2W⚸`cL/XBN$Q'|\۔۠0&d`\ucz@M 2gNe Q[e AZ2CkMŕ9 `KP(_I790 1QdvgygzjB2AY-Q9 RP>T&sb혁n$Kf*r㜀Bn7X8g$yB#Y>у#QڥuL" !Ә 1a(7=%_G}N2VH֜,aA 0X4hS{xw:{3s2scB%=Ȥ+lfA 2xo"s7&2xo"s7&2GFP@ C/ w [Vf{]jNIDsy,X<J75d|@%C`諥)dgin_Gs/YvS'؝AH\okrrWw6#P0ςJf߃mJ*sxśs@7+s2QW8AV{q2 jG,PXԽ 32%> \(e: $9 j/BY0AN(|QE&x|9nU>\E;%P@[ʕw{|B9=, 0^5JW*\ ,Azh)ۻ酂= aj ~=F6ckKg#I8ODѰ+@r1(F='4E&b &I %y댬+hz'$ .r },/n drwma!d{ LĴIZF}  Q5oL_y@TNόdd # e]\6G,Swc$#BY F2(e: Gy(G/0V,LE|+Q{d: Gy(Gp!V[}MN3. c~z(eҕz :B#'l"($d$/FɔΌ.LL*Wq#)TL+-z \ԞY>a$#;WX/_301P@703P$S <ԣc%z'+tDA11BCPF9&+vg+Kˣ'Ǎ fxB !I!}yd >aU-v%{>>ۄ4KU(Bp-࿟5zU~VBȣ4G!s8Ê,}|+|Yf еB# #D>i񍀣P1NIm-ؠP^oP߄‰{d: Gy(G`ܣpCgѲ0#`jޜlEk@3"lD!ޥ-PG!Qд@ƒmnt[K#ܑƛ(sg)@Vq i.NaȼD?hFִK2Ru] Lk)J Wot?5B|{(A!ƧI*;ZLԞ̵f.0 >uMO7»P q@ Q0E!GlisB}+\ m(PkӓRB!̱ w^SxX!=*ߧp2tDWHjmJcOg:B:};Iɩ!V+5 xWvٯK61pG6X`&Q  6,#F  E_Wϩ X !>4(t(UDoQ; uy0>1σ'Q@i;taX|ߓQ: [b0010?Zi$#Y p\(*rK 6Xq)ʚ_:W?֕ ObTm J<%F6< jA]=`XsX!.1!FA$3 ;HG=MN@!5~ e6i$#}2ZpFTm|Fʜ8YYmBYp|3 H>V@G+ Ry2>\~9w ۹7u=UMjAųt2"҂㴒/m՚=UxP# (ur#cQ: YZ 1C$XczJ(Lbdx ]PͲYWm}¾ZLXdT<4Vńu-1f ttm*#Z^"ˈ׌ pl.Whuvx3G!# 9 yas ]^Z7ZL 0G(Xb ZL§-]I~wlI?oGPjĝ`+@;h,.$9 6-_ >&~T]jmK6 |k9P~;dZ{`!+y@ּȺ&m# B~pbj8XxVDaTERճoSg cǩF}WY8fS"3IB˒s95A2(\No *O _`a3&8sso<jB{QY5GM0n;GkFSpSѧ!B{Cʵ'pRY\x|(PwY!BASD?3@0 i pT|b= C}X|<6c\;P@ωqȺBwp4/c&ydR5V}|<6YbR~QiCiGێO6 Qi?IB"Mo(xJ𽭈Osd潂-&Qń9 0G(XbŠ(|Qi%>9 6-W͈?fQP+sF COLDFORTH KERNEL

COLDFORTH Heap Management

TCP/IP places unknown memory demands on a system.

IP requires you to receive an unknown number of datagrams, of unknown size. The datagrams could be IP fragments. You can have an unknown number of datagrams being reconstructed from the fragments. The number of routes is unknown. The number of entries in your ARP table is unknown, and so it goes.

If you are going to support TCP/IP in a manner that is close to the RFC requirements, pre allocation of the memory needed for IP reception is difficult. You have to support ALLOCATE and FREE.

The article describes the COLDFORTH heap management system.

./version081/heapmanagementpaper/buffer_paper.doc0100777000000000000000000014000007300314366020765 0ustar rootrootࡱ> []ZY )bjbjWW -:==%]$; (2222222  /   $1%~& 22222& < 22 < < < 2 22 2 < < ^ S 2@@< COLDFORTH Heap Management TCP/IP places unknown memory demands on a system. IP requires you to receive an unknown number of datagrams, of unknown size. The datagrams could be IP fragments. You can have an unknown number of datagrams being reconstructed from the fragments. The number of routes is unknown. The number of entries in your ARP table is unknown, and so it goes. If you are going to support TCP/IP in a manner that is close to the RFC requirements, pre allocation of the memory needed for IP reception is difficult. You have to support ALLOCATE and FREE. This article describes the COLDFORTH heap management system. Design Aims Portability. All code is in FORTH. Run without an MMU Buffers are self describing; that is all you need to return a buffer is the buffers address. Memory fragmentation is controlled. You can work out what is going on; where and when a buffer is used is recorded. As fast as possible, given the other design aims. Dealing with fragmentation was and is the most difficult problem. Fragmentation Its difficult to put Humpty Dumpty back together. A system that doesn't use a MMU for memory control has to create a small memory area from a larger area, leaving a remainder. When the small area is returned to the heap management system, there is a fair chance that the some of the remainder has been allocated to another task and the large area can no longer be reconstructed. The COLDFORTH heap management system does not solve this problem, but the design makes it possible to quickly recombine buffers that are meant to be combined. Two design decisions set the tone of the whole heap management package. Both reduce de-fragmentation costs. Memory-blocks from which user buffers are created are binary multiples, that is they have a size $40 bytes, $80 bytes, $100 bytes etc. The address of a memory block has bits below its size set to zero. That is, the address of a $80 byte memory block can have the base address $180, but cannot have the base address $140. The following diagram tries to demonstrate the reason for this restriction. INCLUDEPICTURE \d "./joining_buffer.png" Because we insist that the bits below the block size are zero the first case will not happen. The heap management system The heap management system can be divided into two parts. The code you interact with when getting or returning a buffer. And the low level task that recombines the buffers. The data structures The following diagram shows a $40 byte memory block linked into the $40 byte Empty list. INCLUDEPICTURE \d "./small_buffer.png" The following is worth noting: Every memory block starts with a system header. The user buffer is shorter than the memory block The address of the user buffer is after the system header Memory blocks are build out of units that are binary multiple of the minimum memory block size. If you use the word ALLOCATE you will be returned a memory block from one of the empty lists. For example a buffer created from a $40 byte memory block will be returned for any ALLOCATE request less than $1C bytes. The memory block will be $40 bytes, the address returned will be after the system header, and no matter what length requested, the usable data area will be $1C bytes. Any ALLOCATE request greater than $1C bytes and less than $5D bytes will be returned a buffer created from a memory block that was linked into the $80 byte memory block list. This may seem pretty dam inefficient, from a $40 byte memory block the user only gets $1C bytes of usable memory. If you want a $8000 byte buffer, it is created from a $10000 byte memory block. The heap management system has given you a usable buffer $7FDC bytes longer than you need. Yep it's pretty inefficient, but it's a lot better than having your memory broken up into a lot of small chunks that you can't put back together. Getting the memory block When you ask for a memory area, the heap management system first goes to the memory block list that has memory blocks that will just satisfy your needs. If there is no buffer available in the list, the buffer splitting routine _get_more_buffers is called. This routine will go to the next list and attempt to split a bufer form that list into two. If there is no buffer in that list it will go to the next list and ....... _get_more_buffers is a recursive routine. Life is tough for _get_more_buffers , the COLDFIRE heap management system has to be able to meet the needs of tasks running at many different priorities, in a manner that doesn't hold the system up. A low level task can be using _get_more_buffers just to find that a high level task has pinched the buffers created. _get_more_buffers has to be happy and just do the job again, this it does. Putting Humpty Dumpty back together The buffer return words and the buffer_reclaim task co-operate. The buffer return words return the buffers to the list in an address sorted order. This may seem like an excessive runtime overhead. Two things have to be remembered. The buffer_reclaim is trying to keep the list short, and life would be very difficult for buffer_reclaim if the list were not sorted. Because the lists are sorted, because the buffers are allocated in binary multiples, and because the bits below the memory block size have to be zero, buffer reclaim is reasonably simple. Buffer reclaim deals with one buffer size list at a time, trying to combine and move the resultant buffer to the next list. If the base address of the buffer is an acceptable address for the next list up, it checks to see if the next buffer in the list is the next memory block ( _?joinable ). If both these conditions are met the reclaim word joins the buffer and puts it in the next list. Seems simple. Life gets complicated because this must occurs with high priority tasks returning and claiming buffers. A buffer that was in the list when the test was done, may be in use by the time joining is to occur. The complications and how they are dealt with can be seen by looking at the code for _?join_buffer_code Keep track of Humpty Dumpty As soon as you introduce a heap management system, you have memory leaks. If you keep track of memory usage you can determine the guilty and dismiss the innocent. An abort buffer allocated to a task is linked in as shown in the following diagram. INCLUDEPICTURE \d "./abort_buffer.png" The used buffer list heads are only used by words that display buffer usage, for example .buffers and .buffers_used. The abort list is used to return buffers to the central pool on a task abort. The word get_abort_buffer ( pointer n--addr) allows you to supply the address of a cell that is reset to zero on a task abort. The cell is typically used to store the address of the buffer as shown in the diagram. The application however is free to use it as it pleases. application words The COLDFIRE heap management system provides four ways of getting a memory block. PRIVATEworddescriptionreturning wordget_buffer ( n --)The address of the buffer will be returned by buffer. If a task abort occurs the buffer will be returned to the free buffer pool. kill_buffer ( addr --)get_abort_buffer ( pointer n--addr)The system will assume the address of the buffer is stored at pointer, but it doesn't do the store for you. If a task abort occurs the value stored in pointer will be set to zero, and the buffer will be returned to the free buffer pool. If the get_abort_buffer operation fails, an abort occurs.kill_abort_buffer ( addr--)get_free_buffer ( n--)Word returns the address of the buffer. The buffer will not be returned if the task aborts, it is your responsibility. Buffers used to transfer data to TCP/IP ( pep buffers) must be created in this way.kill_free_buffer ( addr--)ALLOCATE ( n --addr ior)If a task abort occurs the buffer will be returned to the free buffer pool. If the ALLOCATE operation fails ior points to a string describing the error.FREE ( addr--)The standard gives us one way to allocate memory from the heap, COLDFORTH gives you four. Some may ask. What is this nonsense?. The standard is very quiet on what happens when a task aborts. Should the memory claimed by the task be returned, or should if be left to the programmer to use CATCH and THROW to return the memory in an orderly fashion. I believe the system should reclaim the memory. When programming you want to deal with the problem not side issues such as this. If ALLOCATE returns memory to the heap management system on an abort, then you need a set of words that does not. When using memory blocks to move data between tasks it is important that aborting one task doesn't invalidate memory owned by another. get_free_buffer and kill_free_buffer are used for this purpose. get_about_buffer and kill_abort_buffer are used to deal with data areas created from the heap. For example: VARIABLE %data_pointer : setup_task ( --) #data_length get_abort_buffer %data_pointer ! ; :task somthing ( --) setup_task task_action ;task If the task aborts the data area will be returned to the heap management system, and the cell containing the pointer reset back to zero. get_buffer and kill_buffer are historic CVS words. They are a lot easier to use than ALLOCATE and FREE. The following code demonstrates their use. : do_some_stuff ( addr n --) DUP get_buffer buffer SWAP MOVE $100 buffer do_stuff get_buffer \ now dealing with \ second buffer buffer do_more_stuffer kill_buffer \ now dealing with first buffer buffer print_stuff kill_buffer ; Basically get_buffer and kill_buffer take the buffer address away from the stack. There is a word ( buffer ) that returns the address of the current buffer. %-26, . W X NV'(BSBJO\!")*+/0;<JL^ E!`!b!x!D"^"`"x"""# #C$H$M$R$5jACJU jU j&U0J6 jU jU6TMx9w>F 0 % , Y ; & FMx9w>F 0 % , Y ;l:i3 eh!0<KL_ E!a!b!y!D"_"`"y"#!#"##%                           J;l:i3 eh!0<K$ & FKL_ E!a!b!y!D"_"`"y"#!#"##%;&&&&&''' v%$ $$  `'R$% %% &&&;&K&P&a&&:'''''($()(-(\(^)j)t)y)))))0J#6%;&&&&&''''''4':'<''[(](z((((((( )):)O)\)^)`)) ''''4':'<''[(](z((((((( )):)O)\)^)`)) v%+0P/ =!"#$%Ddn  c JA&joining_buffer.pngb<:ULE9^ Dn:ULE9^ PNG  IHDR3 PLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4D IDATx흁8%^YgZws].+SK5Xt*l:6 N,,?OGk-k+r9D[Mypn? /]t>?ؖ[)|uJɶܵ9^t!95;':]v-az&.f>n> [6-] tGYqlZ뿓ν츗=V|^ܞYN 6QÄ> S_ >6hnwEґos۾әvb3(lsm=98ߴfeu^g}c=<+7˟mQ|qͫe{dwPL^wF?36[ ?L&͜z1l_lh{NSbmsݓ+{f*Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V*ARDl!Kfr_ 9C)،f6`wlYK6f2polY fQ)\d^3R¦Saөd{0&Rfe ,.l}:EPS@6U>f") }NŅMվYj ¦jǬS5dqaSc)1AMY\Tu,.l}:EPS@6U>f") }NŅMվYj ¦jǬS5dqaSc)1AMY\\iw&eRt*l: {^^}r=Y`ǬܟVcV-1kuP=<(~B"k}PzH@/cH¦jǬ Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V KжA؜͉X16'bb}s$%6U!(bU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V%b3@P_6#PjJf=6Ac3ZT96A{c3ZT56uoވJ"S6 NM¦SaөTt*l:6 NM¦SaөTt*l:6 NM¦SaөT˴ni𯟎 NI֩~.F5] \> !M]ds`E&mas_u\K~>b^˛fX;ͻ-&XރgSou篃͟܇"q2:໐:6G16}ul_،B * ag{6M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab N*6@ 9a3丯P }levrܷf96ýo oeoz ?BL7 NM*~߼C 3tĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ar$V;6 NM¦SaөTt*l:6?^ZLUIENDB`DdfPj  c FA"small_buffer.pngbg~Mkmou$Bng~Mkmou$PNG  IHDRfKXOIDATx뚤Ps[rl ֯jTԈO<ϟ?&n@+D@AD@AD@Aٜ󳚒W7߹m?\l ܱL)_ǵz+s0D\_ĭR0@q'8enˉ^g<1eu,W'6CrqQ[,^jEZ^c~ܜ>nЯY#޵*Fn6mf]x赛ZhzcUl ДTF-W.tn ДbAJ*nMYCN" )JLnj97wqsckm{2 "@  "@Ta?$Y/f;`ޭJSuxz? .vCJA S% ~ۈ+_up5.}i87c:+@],nLj<ƹ/η>yzk n6zZP4nZIz3=N߭dxN;](𰓂6逸\`z>I|s^5GF{{}7CL邥.?(֒=jUcYalDㅿJv.tO5܈)NIdٹwk|Gcpоb˟WKNlyXY nL Jr?b ;e\yLܜAX3_2 \yAr &7}1 o ! "@ c%1q8(!JbHӇC:U .$7G1a&bHdǐxU MR/vpAG 3@lLdޜx5Jg&%1)U>dbHtS"s|,s0}3SEa iZ#yRse橆dCL i'#RCΧ\ ig >'uyB;һ=\Vti=xJ =Xq!|ZZƏx29>{N"/:eҾ[̃qIŐ_bꞫ-DBCD@ i&K %bHS|@1dD@AD@ )@PC.tT>uIv lRgQ,G[ͼ~x\Ȃ-7jooZ̸IBiN%ߴꇷtޮ3Đ~ۋ-2vijy}RGY(w1qIt6 Y:Lxww]>3\XkO~ǧɽ鉧RCZ:*F4z(<PS־ÃRbZY3IcH[;? \VKognvL ~}wϠynڊKӞ+U>CpQnT\F:w4 Ne/t-t#Iy}/qwanϠoC?ФկJXz(1JoR*0[;wtok)*ʎ,hҫ|-N!uxQUOWwRR4qQ^rIj^JA|Ek݁F*#)ثw.zh1u?:LR bAta3xC `X@ i&K %$\2 "@  "@  (!M1]`y`u*-=1C'cE_SnӽϺxll!;6rL9{qKnJ}ʜ5Nrgƾtěm.* I?g4d9vV )CzGy8l͝so3w+m[5Lv iSVߐeE@u$nMum~I,,ۗ$K_vτ2<ЈhKu7eǐK!mIX1)ٶ{m;"D !H{7dj(a%C|H IǍ622N{4ł2 2"@ bH;0A]bH/C:瘏s ((R$t9]6iKm4%;tmM t$TcFV(0 /"٤Ut>Gm.ˉɕC:= MZE_qOcV3?sf1MZ]U;qỲcH7&eMblU:8M/"mVÃW>MĐ&Z6ES 'N.XɎ!ݛmMڤGW36v׎8WCƲIŐ^iq\J 闵CE{HƵwiGi\7їg #-3"@ bH;0A]bH/C:瘏s ((R$bDcH/&!%c+cH[;W$R@g!$1mCž>pbHk+tuLspsEa cͯS E'f-G.ŐqCZ`5eJbH!-0ҶǾTseZA*4y_;\T= |~7\ԔZyzyмw9NW%o8*ze}CC8Peۛp#s|7^izܶwWwXv^uY{_ |~os+L݋g^JۛY_Yt߾yΟ2֚ʽ̝9CV:ma23??ӿr]w2@bOue94ݙHzo=9>ITR{ <B7!S.uSnT묊ϖu<;D37?://oNOYW_  W-aO_X?}LAª}C1>6O CzX/{C 9q)Ӈ2'$vwqs|}ͮ}0ݡl0. `uI1~u=|r_2DIC_xhOZT/]Ȼ ǧ"{u[% (zq7kJJxR/{oNEO]>>}7nC쮂H doozC^yqYI.}H[ߍ ^a-X1Խ_L"m- Qk7 ^ 2"@  "@  Cz3%3o5ŭcah)4MI "R yXO/fZ#w ;<8*J!:Q\A0A5EEsuU=|<$]_Ԫ&8u2g3$y\ [^?گ5;{ UʓjH#R/W^We~V+g,ڔM#CR󭖉]Ͻ|<@E'=eԈ L_9U)0F|k:R-/_SU: ekI[xI@-'qo_=xf|`xq(;2Q7ތ<ƴR !Kb*3̣&/kbJbywTы+#d@CQj8 |*ja.S!~Y^/vj©erLEߍFQwlfJe\>o< Of>}|q Ul_ttJ׋ôwfkӑC\)x[G )ˋWlDG*D㒙v/ "R鈂PGږ/Syj"ӽUg,4NABM.ykg 5(BMu " Qy*N(،KQ0(((((((((P.N͐D@AD@ArY4 ; P P6P PuD@9ܧ`ߦd(dD@AD@AD@AD@AD@AwcIENDB`Dd wj  c FA"abort_buffer.pngbF`U^d"'n`U^dPNG  IHDR wKPLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4DIDATx흍 F}9D Fтzt%)>pCՄjnVQpQpQPY7sh[ܾmGa(=Apu熿~-ޯ\G3H&R ~$A?mjtZ/S^ޚ(j4B7nO=`j`#3 V) g h51Mw4g%|,i==<7G, ' p f?N=Qca\^GaL2W⚸`cL/XBN$Q'|\۔۠0&d`\ucz@M 2gNe Q[e AZ2CkMŕ9 `KP(_I790 1QdvgygzjB2AY-Q9 RP>T&sb혁n$Kf*r㜀Bn7X8g$yB#Y>у#QڥuL" !Ә 1a(7=%_G}N2VH֜,aA 0X4hS{xw:{3s2scB%=Ȥ+lfA 2xo"s7&2xo"s7&2GFP@ C/ w [Vf{]jNIDsy,X<J75d|@%C`諥)dgin_Gs/YvS'؝AH\okrrWw6#P0ςJf߃mJ*sxśs@7+s2QW8AV{q2 jG,PXԽ 32%> \(e: $9 j/BY0AN(|QE&x|9nU>\E;%P@[ʕw{|B9=, 0^5JW*\ ,Azh)ۻ酂= aj ~=F6ckKg#I8ODѰ+@r1(F='4E&b &I %y댬+hz'$ .r },/n drwma!d{ LĴIZF}  Q5oL_y@TNόdd # e]\6G,Swc$#BY F2(e: Gy(G/0V,LE|+Q{d: Gy(Gp!V[}MN3. c~z(eҕz :B#'l"($d$/FɔΌ.LL*Wq#)TL+-z \ԞY>a$#;WX/_301P@703P$S <ԣc%z'+tDA11BCPF9&+vg+Kˣ'Ǎ fxB !I!}yd >aU-v%{>>ۄ4KU(Bp-࿟5zU~VBȣ4G!s8Ê,}|+|Yf еB# #D>i񍀣P1NIm-ؠP^oP߄‰{d: Gy(G`ܣpCgѲ0#`jޜlEk@3"lD!ޥ-PG!Qд@ƒmnt[K#ܑƛ(sg)@Vq i.NaȼD?hFִK2Ru] Lk)J Wot?5B|{(A!ƧI*;ZLԞ̵f.0 >uMO7»P q@ Q0E!GlisB}+\ m(PkӓRB!̱ w^SxX!=*ߧp2tDWHjmJcOg:B:};Iɩ!V+5 xWvٯK61pG6X`&Q  6,#F  E_Wϩ X !>4(t(UDoQ; uy0>1σ'Q@i;taX|ߓQ: [b0010?Zi$#Y p\(*rK 6Xq)ʚ_:W?֕ ObTm J<%F6< jA]=`XsX!.1!FA$3 ;HG=MN@!5~ e6i$#}2ZpFTm|Fʜ8YYmBYp|3 H>V@G+ Ry2>\~9w ۹7u=UMjAųt2"҂㴒/m՚=UxP# (ur#cQ: YZ 1C$XczJ(Lbdx ]PͲYWm}¾ZLXdT<4Vńu-1f ttm*#Z^"ˈ׌ pl.Whuvx3G!# 9 yas ]^Z7ZL 0G(Xb ZL§-]I~wlI?oGPjĝ`+@;h,.$9 6-_ >&~T]jmK6 |k9P~;dZ{`!+y@ּȺ&m# B~pbj8XxVDaTERճoSg cǩF}WY8fS"3IB˒s95A2(\No *O _`a3&8sso<jB{QY5GM0n;GkFSpSѧ!B{Cʵ'pRY\x|(PwY!BASD?3@0 i pT|b= C}X|<6c\;P@ωqȺBwp4/c&ydR5V}|<6YbR~QiCiGێO6 Qi?IB"Mo(xJ𽭈Osd潂-&Qń9 0G(XbŠ(|Qi%>9 6-W͈?fQP+sFO>Definition Listh(O( Definition6(O(H1$ 5CJ0KH$$O$H2$5CJ$$O$H3$5CJ O H4$5$O$H5$5CJ$O$H6$5CJ.O.Address 60O0 Blockquote hhOCITE6(O(CODECJOJQJkH$X@$Emphasis6(U@( Hyperlink>*B*8V@8FollowedHyperlink>*B* 4O4Keyboard5CJOJQJkHjOj Preformatted0  # ~= z9!v%CJOJQJkHXOXz-Bottom of Form!$1$$d<CJOJQJkHmH ROR z-Top of Form"$1$&d<CJOJQJkHmH (O1(Sample OJQJkH W@A Strong54OQ4 TypewriterCJOJQJkH$Oa$Variable6,Oq, HTML Markup<B*"O"Comment<%:R$);K')%)-W  %C C C }(./5'pu(CSP\LV "EVY]bqDTW[ostw! """;"K"P"a""""""""""# ###&#(#3#######_$l$o$s$$$$$$$$% %%C%N%P%[%j%t%y%%&charlese-C:\TEMP\AutoRecovery save of buffer_paper.asdcharlese.C:\BCM550\heapmanagementpaper\buffer_paper.doc*PN\N @h OJQJo(@HP DeskJet 660CLPT1:winspoolHP DeskJet 660CHP DeskJet 660Cpj,,Letter ''''HP DeskJet 660Cpj,,Letter ''''%%t%%%@@GTimes New Roman5Symbol3& Arial?5 Courier New"@hf:f:P:vY$0=-,COLDFORTH KERNELforth Charles EssoncharleseOh+'0 $0 L X d p|COLDFORTH KERNELdOLDCharles EssonELforths ort Normal.doto charleseto2arMicrosoft Word 8.0@F#@J @@v՜.+,D՜.+,P  hp  Colour Vision Systems Y=-j COLDFORTH KERNEL Title 0nv _PID_GUID _PID_HLINKS descriptionAN{D6914171-897B-11D3-B769-0060083135F2}A,F, joining_buffer.png_( small_buffer.png[9abort_buffer.png0 COLDFORTH uses this file to generate COLDFORTH  !"#$%&'()*+,-./0123456789:;<=>?@BCDEFGHIKLMNOPQSTUVWXY\Root Entry F`@QL^Data D1TableAWordDocument-:SummaryInformation(JDocumentSummaryInformation8iRCompObj( jObjectPool @QL@QL  FMicrosoft Word Document MSWordDocWord.Document.89q./version081/heapmanagementpaper/buffer_paper.html0100777000000000000000000002774607300314366021211 0ustar rootroot COLDFORTH KERNEL

COLDFORTH Heap Management

TCP/IP places unknown memory demands on a system.

IP requires you to receive an unknown number of datagrams, of unknown size. The datagrams could be IP fragments. You can have an unknown number of datagrams being reconstructed from the fragments. The number of routes is unknown. The number of entries in your ARP table is unknown, and so it goes.

If you are going to support TCP/IP in a manner that is close to the RFC requirements, pre allocation of the memory needed for IP reception is difficult. You have to support ALLOCATE and FREE.

This article describes the COLDFORTH heap management system.

Design Aims

  • Portability. All code is in FORTH.
  • Run without an MMU
  • Buffers are self describing; that is all you need to return a buffer is the buffers address.
  • Memory fragmentation is controlled.
  • You can work out what is going on; where and when a buffer is used is recorded.
  • As fast as possible, given the other design aims.

Dealing with fragmentation was and is the most difficult problem.

Fragmentation

Its difficult to put Humpty Dumpty back together.

A system that doesn't use a MMU for memory control has to create a small memory area from a larger area, leaving a remainder. When the small area is returned to the heap management system, there is a fair chance that the some of the remainder has been allocated to another task and the large area can no longer be reconstructed.

The COLDFORTH heap management system does not solve this problem, but the design makes it possible to quickly recombine buffers that are meant to be combined.

Two design decisions set the tone of the whole heap management package. Both reduce de-fragmentation costs.

Memory-blocks from which user buffers are created are binary multiples, that is they have a size $40 bytes, $80 bytes, $100 bytes etc.

The address of a memory block has bits below its size set to zero. That is, the address of a $80 byte memory block can have the base address $180, but cannot have the base address $140. The following diagram tries to demonstrate the reason for this restriction.

Because we insist that the bits below the block size are zero the first case will not happen.

The heap management system

The heap management system can be divided into two parts. The code you interact with when getting or returning a buffer. And the low level task that recombines the buffers.

The data structures

The following diagram shows a $40 byte memory block linked into the $40 byte Empty list.

The following is worth noting:

  • Every memory block starts with a system header.
  • The user buffer is shorter than the memory block
  • The address of the user buffer is after the system header
  • Memory blocks are build out of units that are binary multiple of the minimum memory block size.

If you use the word ALLOCATE you will be returned a memory block from one of the empty lists. For example a buffer created from a $40 byte memory block will be returned for any ALLOCATE request less than $1C bytes. The memory block will be $40 bytes, the address returned will be after the system header, and no matter what length requested, the usable data area will be $1C bytes.

Any ALLOCATE request greater than $1C bytes and less than $5D bytes will be returned a buffer created from a memory block that was linked into the $80 byte memory block list.

This may seem pretty dam inefficient, from a $40 byte memory block the user only gets $1C bytes of usable memory. If you want a $8000 byte buffer, it is created from a $10000 byte memory block. The heap management system has given you a usable buffer $7FDC bytes longer than you need.

Yep it's pretty inefficient, but it's a lot better than having your memory broken up into a lot of small chunks that you can't put back together.

Getting the memory block

When you ask for a memory area, the heap management system first goes to the memory block list that has memory blocks that will just satisfy your needs. If there is no buffer available in the list, the buffer splitting routine _get_more_buffers is called. This routine will go to the next list and attempt to split a buffer form that list into two. If there is no buffer in that list it will go to the next list and ....... _get_more_buffers is a recursive routine.

Life is tough for _get_more_buffers , the COLDFIRE heap management system has to be able to meet the needs of tasks running at many different priorities, in a manner that doesn't hold the system up.

A low level task can be using _get_more_buffers just to find that a high level task has pinched the buffers created. _get_more_buffers has to be happy and just do the job again, this it does.

Putting Humpty Dumpty back together

The buffer return words and the buffer_reclaim task co-operate. The buffer return words return the buffers to the list in an address sorted order. This may seem like an excessive runtime overhead. Two things have to be remembered. The buffer_reclaim is trying to keep the list short, and life would be very difficult for buffer_reclaim if the list were not sorted.

Because the lists are sorted, because the buffers are allocated in binary multiples, and because the bits below the memory block size have to be zero, buffer reclaim is reasonably simple.

Buffer reclaim deals with one buffer size list at a time, trying to combine and move the resultant buffer to the next list. If the base address of the buffer is an acceptable address for the next list up, it checks to see if the next buffer in the list is the next memory block ( _?joinable ). If both these conditions are met the reclaim word joins the buffer and puts it in the next list.

Seems simple. Life gets complicated because this must occurs with high priority tasks returning and claiming buffers. A buffer that was in the list when the test was done, may be in use by the time joining is to occur. The complications and how they are dealt with can be seen by looking at the code for _?join_buffer_code

Keep track of Humpty Dumpty

As soon as you introduce a heap management system, you have memory leaks. If you keep track of memory usage you can determine the guilty and dismiss the innocent

An abort buffer allocated to a task is linked in as shown in the following diagram.

The used buffer list heads are only used by words that display buffer usage, for example .buffers and .buffers_used. The abort list is used to return buffers to the central pool on a task abort. The word get_abort_buffer ( pointer n--addr) allows you to supply the address of a cell that is reset to zero on a task abort. The cell is typically used to store the address of the buffer as shown in the diagram. The application however is free to use it as it pleases.

application words

The COLDFIRE heap management system provides four ways of getting a memory block.

word description returning word
get_buffer ( n --) The address of the buffer will be returned by buffer. If a task abort occurs the buffer will be returned to the free buffer pool. kill_buffer ( addr --)
get_abort_buffer ( pointer n--addr) The system will assume the address of the buffer is stored at pointer, but it doesn't do the store for you. If a task abort occurs the value stored in pointer will be set to zero, and the buffer will be returned to the free buffer pool. If the get_abort_buffer operation fails, an abort occurs. kill_abort_buffer ( addr--)
get_free_buffer ( n--) Word returns the address of the buffer. The buffer will not be returned if the task aborts, it is your responsibility. Buffers used to transfer data to TCP/IP ( pep buffers) must be created in this way. kill_free_buffer ( addr--)
ALLOCATE ( n --addr ior) If a task abort occurs the buffer will be returned to the free buffer pool. If the ALLOCATE operation fails ior points to a string describing the error. FREE ( addr--)

The standard gives us one way to allocate memory from the heap, COLDFORTH gives you four. Some may ask. What is this nonsense?.

The standard is very quiet on what happens when a task aborts. Should the memory claimed by the task be returned, or should if be left to the programmer to use CATCH and THROW to return the memory in an orderly fashion. I believe the system should reclaim the memory. When programming you want to deal with the problem not side issues such as this.

If ALLOCATE returns memory to the heap management system on an abort, then you need a set of words that does not. When using memory blocks to move data between tasks it is important that aborting one task doesn't invalidate memory owned by another. get_free_buffer and kill_free_buffer are used for this purpose.

get_about_buffer and kill_abort_buffer are used to deal with data areas created from the heap. For example: 

 
VARIABLE %data_pointer
: setup_task ( --)
	#data_length get_abort_buffer %data_pointer !
;

:task somthing ( --)
	setup_task
	task_action
;task

If the task aborts the data area will be returned to the heap management system, and the cell containing the pointer reset back to zero.

get_buffer and kill_buffer are historic CVS words. They are a lot easier to use than ALLOCATE and FREE. The following code demonstrates their use. 

 
: do_some_stuff ( addr n --)
	DUP get_buffer
		buffer  SWAP MOVE
		$100 buffer do_stuff
			get_buffer
				\ now dealing with second buffer
				buffer do_more_stuffer
			kill_buffer
		\ now dealing with first buffer
		buffer print_stuff
	kill_buffer
;

Basically get_buffer and kill_buffer take the buffer address away from the stack. There is a word ( buffer ) that returns the address of the current buffer.

./version081/heapmanagementpaper/buffer_paper_slides.doc0100777000000000000000000014000007300314366022330 0ustar rootrootࡱ> []ZY )bjbjWW -:==%]$  (2222222  /   $~ 22222 22  2^22 2 b 0 S 2@0 COLDFORTH Heap Management TCP/IP places unknown memory demands on a system. IP requires you to receive an unknown number of datagrams, of unknown size. The datagrams could be IP fragments. You can have an unknown number of datagrams being reconstructed from the fragments. The number of routes is unknown. The number of entries in your ARP table is unknown, and so it goes. If you are going to support TCP/IP in a manner that is close to the RFC requirements, pre allocation of the memory needed for IP reception is difficult. You have to support ALLOCATE and FREE. This article describes the COLDFORTH heap management system. Design Aims Portability. All code is in FORTH. Run without an MMU Buffers are self describing; that is all you need to return a buffer is the buffers address. Memory fragmentation is controlled. You can work out what is going on; where and when a buffer is used is recorded. As fast as possible, given the other design aims. Dealing with fragmentation was and is the most difficult problem. Fragmentation Its difficult to put Humpty Dumpty back together. A system that doesn't use a MMU for memory control has to create a small memory area from a larger area, leaving a remainder. When the small area is returned to the heap management system, there is a fair chance that the some of the remainder has been allocated to another task and the large area can no longer be reconstructed. The COLDFORTH heap management system does not solve this problem, but the design makes it possible to quickly recombine buffers that are meant to be combined. Two design decisions set the tone of the whole heap management package. Both reduce de-fragmentation costs. Memory-blocks from which user buffers are created are binary multiples, that is they have a size $40 bytes, $80 bytes, $100 bytes etc. The address of a memory block has bits below its size set to zero. That is, the address of a $80 byte memory block can have the base address $180, but cannot have the base address $140. The following diagram tries to demonstrate the reason for this restriction. INCLUDEPICTURE \d "./joining_buffer.png" Because we insist that the bits below the block size are zero the first case will not happen. The heap management system The heap management system can be divided into two parts. The code you interact with when getting or returning a buffer. And the low level task that recombines the buffers. The data structures The following diagram shows a $40 byte memory block linked into the $40 byte Empty list. INCLUDEPICTURE \d "./small_buffer.png" The following is worth noting: Every memory block starts with a system header. The user buffer is shorter than the memory block The address of the user buffer is after the system header Memory blocks are build out of units that are binary multiple of the minimum memory block size. If you use the word ALLOCATE you will be returned a memory block from one of the empty lists. For example a buffer created from a $40 byte memory block will be returned for any ALLOCATE request less than $1C bytes. The memory block will be $40 bytes, the address returned will be after the system header, and no matter what length requested, the usable data area will be $1C bytes. Any ALLOCATE request greater than $1C bytes and less than $5D bytes will be returned a buffer created from a memory block that was linked into the $80 byte memory block list. This may seem pretty dam inefficient, from a $40 byte memory block the user only gets $1C bytes of usable memory. If you want a $8000 byte buffer, it is created from a $10000 byte memory block. The heap management system has given you a usable buffer $7FDC bytes longer than you need. Yep it's pretty inefficient, but it's a lot better than having your memory broken up into a lot of small chunks that you can't put back together. Getting the memory block When you ask for a memory area, the heap management system first goes to the memory block list that has memory blocks that will just satisfy your needs. If there is no buffer available in the list, the buffer splitting routine _get_more_buffers is called. This routine will go to the next list and attempt to split a bufer form that list into two. If there is no buffer in that list it will go to the next list and ....... _get_more_buffers is a recursive routine. Life is tough for _get_more_buffers , the COLDFIRE heap management system has to be able to meet the needs of tasks running at many different priorities, in a manner that doesn't hold the system up. A low level task can be using _get_more_buffers just to find that a high level task has pinched the buffers created. _get_more_buffers has to be happy and just do the job again, this it does. Putting Humpty Dumpty back together The buffer return words and the buffer_reclaim task co-operate. The buffer return words return the buffers to the list in an address sorted order. This may seem like an excessive runtime overhead. Two things have to be remembered. The buffer_reclaim is trying to keep the list short, and life would be very difficult for buffer_reclaim if the list were not sorted. Because the lists are sorted, because the buffers are allocated in binary multiples, and because the bits below the memory block size have to be zero, buffer reclaim is reasonably simple. Buffer reclaim deals with one buffer size list at a time, trying to combine and move the resultant buffer to the next list. If the base address of the buffer is an acceptable address for the next list up, it checks to see if the next buffer in the list is the next memory block ( _?joinable ). If both these conditions are met the reclaim word joins the buffer and puts it in the next list. Seems simple. Life gets complicated because this must occurs with high priority tasks returning and claiming buffers. A buffer that was in the list when the test was done, may be in use by the time joining is to occur. The complications and how they are dealt with can be seen by looking at the code for _?join_buffer_code Keep track of Humpty Dumpty As soon as you introduce a heap management system, you have memory leaks. If you keep track of memory usage you can determine the guilty and dismiss the innocent. An abort buffer allocated to a task is linked in as shown in the following diagram. INCLUDEPICTURE \d "./abort_buffer.png" The used buffer list heads are only used by words that display buffer usage, for example .buffers and .buffers_used. The abort list is used to return buffers to the central pool on a task abort. The word get_abort_buffer ( pointer n--addr) allows you to supply the address of a cell that is reset to zero on a task abort. The cell is typically used to store the address of the buffer as shown in the diagram. The application however is free to use it as it pleases. application words The COLDFIRE heap management system provides four ways of getting a memory block. PRIVATEworddescriptionreturning wordget_buffer ( n --)The address of the buffer will be returned by buffer. If a task abort occurs the buffer will be returned to the free buffer pool. kill_buffer ( addr --)get_abort_buffer ( pointer n--addr)The system will assume the address of the buffer is stored at pointer, but it doesn't do the store for you. If a task abort occurs the value stored in pointer will be set to zero, and the buffer will be returned to the free buffer pool. If the get_abort_buffer operation fails, an abort occurs.kill_abort_buffer ( addr--)get_free_buffer ( n--)Word returns the address of the buffer. The buffer will not be returned if the task aborts, it is your responsibility. Buffers used to transfer data to TCP/IP ( pep buffers) must be created in this way.kill_free_buffer ( addr--)ALLOCATE ( n --addr ior)If a task abort occurs the buffer will be returned to the free buffer pool. If the ALLOCATE operation fails ior points to a string describing the error.FREE ( addr--)The standard gives us one way to allocate memory from the heap, COLDFORTH gives you four. Some may ask. What is this nonsense?. The standard is very quiet on what happens when a task aborts. Should the memory claimed by the task be returned, or should if be left to the programmer to use CATCH and THROW to return the memory in an orderly fashion. I believe the system should reclaim the memory. When programming you want to deal with the problem not side issues such as this. If ALLOCATE returns memory to the heap management system on an abort, then you need a set of words that does not. When using memory blocks to move data between tasks it is important that aborting one task doesn't invalidate memory owned by another. get_free_buffer and kill_free_buffer are used for this purpose. get_about_buffer and kill_abort_buffer are used to deal with data areas created from the heap. For example: VARIABLE %data_pointer : setup_task ( --) #data_length get_abort_buffer %data_pointer ! ; :task somthing ( --) setup_task task_action ;task If the task aborts the data area will be returned to the heap management system, and the cell containing the pointer reset back to zero. get_buffer and kill_buffer are historic CVS words. They are a lot easier to use than ALLOCATE and FREE. The following code demonstrates their use. : do_some_stuff ( addr n --) DUP get_buffer buffer SWAP MOVE $100 buffer do_stuff get_buffer \ now dealing with \ second buffer buffer do_more_stuffer kill_buffer \ now dealing with first buffer buffer print_stuff kill_buffer ; Basically get_buffer and kill_buffer take the buffer address away from the stack. There is a word ( buffer ) that returns the address of the current buffer. %-26, . W X NV'(BSBJO\!")*+/0;<JL^ E!`!b!x!D"^"`"x"""# #C$H$M$R$5jACJU jU j&U0J6 jU jU6TMx9w>F 0 % , Y ; & FMx9w>F 0 % , Y ;l:i3 eh!0<KL_ E!a!b!y!D"_"`"y"#!#"##%                           J;l:i3 eh!0<K$ & FKL_ E!a!b!y!D"_"`"y"#!#"##%;&&&&&''' v%$ $$  `'R$% %% &&&;&K&P&a&&:'''''($()(-(\(^)j)t)y)))))0J#6%;&&&&&''''''4':'<''[(](z((((((( )):)O)\)^)`)) ''''4':'<''[(](z((((((( )):)O)\)^)`)) v%+0P/ =!"#$%Ddn  c JA&joining_buffer.pngb<:ULE9^ D n:ULE9^ PNG  IHDR3 PLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4D IDATx흁8%^YgZws].+SK5Xt*l:6 N,,?OGk-k+r9D[Mypn? /]t>?ؖ[)|uJɶܵ9^t!95;':]v-az&.f>n> [6-] tGYqlZ뿓ν츗=V|^ܞYN 6QÄ> S_ >6hnwEґos۾әvb3(lsm=98ߴfeu^g}c=<+7˟mQ|qͫe{dwPL^wF?36[ ?L&͜z1l_lh{NSbmsݓ+{f*Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V*ARDl!Kfr_ 9C)،f6`wlYK6f2polY fQ)\d^3R¦Saөd{0&Rfe ,.l}:EPS@6U>f") }NŅMվYj ¦jǬS5dqaSc)1AMY\Tu,.l}:EPS@6U>f") }NŅMվYj ¦jǬS5dqaSc)1AMY\\iw&eRt*l: {^^}r=Y`ǬܟVcV-1kuP=<(~B"k}PzH@/cH¦jǬ Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V KжA؜͉X16'bb}s$%6U!(bU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V%b3@P_6#PjJf=6Ac3ZT96A{c3ZT56uoވJ"S6 NM¦SaөTt*l:6 NM¦SaөTt*l:6 NM¦SaөT˴ni𯟎 NI֩~.F5] \> !M]ds`E&mas_u\K~>b^˛fX;ͻ-&XރgSou篃͟܇"q2:໐:6G16}ul_،B * ag{6M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab N*6@ 9a3丯P }levrܷf96ýo oeoz ?BL7 NM*~߼C 3tĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ar$V;6 NM¦SaөTt*l:6?^ZLUIENDB`DdfPj  c FA"small_buffer.pngbg~Mkmou$B ng~Mkmou$PNG  IHDRfKXOIDATx뚤Ps[rl ֯jTԈO<ϟ?&n@+D@AD@AD@Aٜ󳚒W7߹m?\l ܱL)_ǵz+s0D\_ĭR0@q'8enˉ^g<1eu,W'6CrqQ[,^jEZ^c~ܜ>nЯY#޵*Fn6mf]x赛ZhzcUl ДTF-W.tn ДbAJ*nMYCN" )JLnj97wqsckm{2 "@  "@Ta?$Y/f;`ޭJSuxz? .vCJA S% ~ۈ+_up5.}i87c:+@],nLj<ƹ/η>yzk n6zZP4nZIz3=N߭dxN;](𰓂6逸\`z>I|s^5GF{{}7CL邥.?(֒=jUcYalDㅿJv.tO5܈)NIdٹwk|Gcpоb˟WKNlyXY nL Jr?b ;e\yLܜAX3_2 \yAr &7}1 o ! "@ c%1q8(!JbHӇC:U .$7G1a&bHdǐxU MR/vpAG 3@lLdޜx5Jg&%1)U>dbHtS"s|,s0}3SEa iZ#yRse橆dCL i'#RCΧ\ ig >'uyB;һ=\Vti=xJ =Xq!|ZZƏx29>{N"/:eҾ[̃qIŐ_bꞫ-DBCD@ i&K %bHS|@1dD@AD@ )@PC.tT>uIv lRgQ,G[ͼ~x\Ȃ-7jooZ̸IBiN%ߴꇷtޮ3Đ~ۋ-2vijy}RGY(w1qIt6 Y:Lxww]>3\XkO~ǧɽ鉧RCZ:*F4z(<PS־ÃRbZY3IcH[;? \VKognvL ~}wϠynڊKӞ+U>CpQnT\F:w4 Ne/t-t#Iy}/qwanϠoC?ФկJXz(1JoR*0[;wtok)*ʎ,hҫ|-N!uxQUOWwRR4qQ^rIj^JA|Ek݁F*#)ثw.zh1u?:LR bAta3xC `X@ i&K %$\2 "@  "@  (!M1]`y`u*-=1C'cE_SnӽϺxll!;6rL9{qKnJ}ʜ5Nrgƾtěm.* I?g4d9vV )CzGy8l͝so3w+m[5Lv iSVߐeE@u$nMum~I,,ۗ$K_vτ2<ЈhKu7eǐK!mIX1)ٶ{m;"D !H{7dj(a%C|H IǍ622N{4ł2 2"@ bH;0A]bH/C:瘏s ((R$t9]6iKm4%;tmM t$TcFV(0 /"٤Ut>Gm.ˉɕC:= MZE_qOcV3?sf1MZ]U;qỲcH7&eMblU:8M/"mVÃW>MĐ&Z6ES 'N.XɎ!ݛmMڤGW36v׎8WCƲIŐ^iq\J 闵CE{HƵwiGi\7їg #-3"@ bH;0A]bH/C:瘏s ((R$bDcH/&!%c+cH[;W$R@g!$1mCž>pbHk+tuLspsEa cͯS E'f-G.ŐqCZ`5eJbH!-0ҶǾTseZA*4y_;\T= |~7\ԔZyzyмw9NW%o8*ze}CC8Peۛp#s|7^izܶwWwXv^uY{_ |~os+L݋g^JۛY_Yt߾yΟ2֚ʽ̝9CV:ma23??ӿr]w2@bOue94ݙHzo=9>ITR{ <B7!S.uSnT묊ϖu<;D37?://oNOYW_  W-aO_X?}LAª}C1>6O CzX/{C 9q)Ӈ2'$vwqs|}ͮ}0ݡl0. `uI1~u=|r_2DIC_xhOZT/]Ȼ ǧ"{u[% (zq7kJJxR/{oNEO]>>}7nC쮂H doozC^yqYI.}H[ߍ ^a-X1Խ_L"m- Qk7 ^ 2"@  "@  Cz3%3o5ŭcah)4MI "R yXO/fZ#w ;<8*J!:Q\A0A5EEsuU=|<$]_Ԫ&8u2g3$y\ [^?گ5;{ UʓjH#R/W^We~V+g,ڔM#CR󭖉]Ͻ|<@E'=eԈ L_9U)0F|k:R-/_SU: ekI[xI@-'qo_=xf|`xq(;2Q7ތ<ƴR !Kb*3̣&/kbJbywTы+#d@CQj8 |*ja.S!~Y^/vj©erLEߍFQwlfJe\>o< Of>}|q Ul_ttJ׋ôwfkӑC\)x[G )ˋWlDG*D㒙v/ "R鈂PGږ/Syj"ӽUg,4NABM.ykg 5(BMu " Qy*N(،KQ0(((((((((P.N͐D@AD@ArY4 ; P P6P PuD@9ܧ`ߦd(dD@AD@AD@AD@AD@AwcIENDB`Dd wj  c FA"abort_buffer.pngbF`U^d"' n`U^dPNG  IHDR wKPLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4DIDATx흍 F}9D Fтzt%)>pCՄjnVQpQpQPY7sh[ܾmGa(=Apu熿~-ޯ\G3H&R ~$A?mjtZ/S^ޚ(j4B7nO=`j`#3 V) g h51Mw4g%|,i==<7G, ' p f?N=Qca\^GaL2W⚸`cL/XBN$Q'|\۔۠0&d`\ucz@M 2gNe Q[e AZ2CkMŕ9 `KP(_I790 1QdvgygzjB2AY-Q9 RP>T&sb혁n$Kf*r㜀Bn7X8g$yB#Y>у#QڥuL" !Ә 1a(7=%_G}N2VH֜,aA 0X4hS{xw:{3s2scB%=Ȥ+lfA 2xo"s7&2xo"s7&2GFP@ C/ w [Vf{]jNIDsy,X<J75d|@%C`諥)dgin_Gs/YvS'؝AH\okrrWw6#P0ςJf߃mJ*sxśs@7+s2QW8AV{q2 jG,PXԽ 32%> \(e: $9 j/BY0AN(|QE&x|9nU>\E;%P@[ʕw{|B9=, 0^5JW*\ ,Azh)ۻ酂= aj ~=F6ckKg#I8ODѰ+@r1(F='4E&b &I %y댬+hz'$ .r },/n drwma!d{ LĴIZF}  Q5oL_y@TNόdd # e]\6G,Swc$#BY F2(e: Gy(G/0V,LE|+Q{d: Gy(Gp!V[}MN3. c~z(eҕz :B#'l"($d$/FɔΌ.LL*Wq#)TL+-z \ԞY>a$#;WX/_301P@703P$S <ԣc%z'+tDA11BCPF9&+vg+Kˣ'Ǎ fxB !I!}yd >aU-v%{>>ۄ4KU(Bp-࿟5zU~VBȣ4G!s8Ê,}|+|Yf еB# #D>i񍀣P1NIm-ؠP^oP߄‰{d: Gy(G`ܣpCgѲ0#`jޜlEk@3"lD!ޥ-PG!Qд@ƒmnt[K#ܑƛ(sg)@Vq i.NaȼD?hFִK2Ru] Lk)J Wot?5B|{(A!ƧI*;ZLԞ̵f.0 >uMO7»P q@ Q0E!GlisB}+\ m(PkӓRB!̱ w^SxX!=*ߧp2tDWHjmJcOg:B:};Iɩ!V+5 xWvٯK61pG6X`&Q  6,#F  E_Wϩ X !>4(t(UDoQ; uy0>1σ'Q@i;taX|ߓQ: [b0010?Zi$#Y p\(*rK 6Xq)ʚ_:W?֕ ObTm J<%F6< jA]=`XsX!.1!FA$3 ;HG=MN@!5~ e6i$#}2ZpFTm|Fʜ8YYmBYp|3 H>V@G+ Ry2>\~9w ۹7u=UMjAųt2"҂㴒/m՚=UxP# (ur#cQ: YZ 1C$XczJ(Lbdx ]PͲYWm}¾ZLXdT<4Vńu-1f ttm*#Z^"ˈ׌ pl.Whuvx3G!# 9 yas ]^Z7ZL 0G(Xb ZL§-]I~wlI?oGPjĝ`+@;h,.$9 6-_ >&~T]jmK6 |k9P~;dZ{`!+y@ּȺ&m# B~pbj8XxVDaTERճoSg cǩF}WY8fS"3IB˒s95A2(\No *O _`a3&8sso<jB{QY5GM0n;GkFSpSѧ!B{Cʵ'pRY\x|(PwY!BASD?3@0 i pT|b= C}X|<6c\;P@ωqȺBwp4/c&ydR5V}|<6YbR~QiCiGێO6 Qi?IB"Mo(xJ𽭈Osd潂-&Qń9 0G(XbŠ(|Qi%>9 6-W͈?fQP+sF>Definition Listh(O( Definition6((H1$ 5CJ0KH$$O$H2$5CJ$$O$H3$5CJ O H4$5$$H5$5CJ$$H6$5CJ..Address 600 Blockquote hhOCITE6(O(CODECJOJQJkH$X@$Emphasis6(U@( Hyperlink>*B*8V@8FollowedHyperlink>*B* 4O4Keyboard5CJOJQJkHjOj Preformatted0  # ~= z9!v%CJOJQJkHXXz-Bottom of Form!$1$$d<CJOJQJkHmH RR z-Top of Form"$1$&d<CJOJQJkHmH (O1(Sample OJQJkH W@A Strong54OQ4 TypewriterCJOJQJkH$Oa$Variable6,Oq, HTML Markup<B*"O"Comment<%:R$);K')%)-W  %C C C }(./5'pu(BCSOP\LV "EVY]bqDTW[mostw! """;"K"P"a"""""""""""""# ###&#(#3#######_$l$o$s$$$$$$$$% %%C%N%P%[%j%t%y%%&charlese-C:\TEMP\AutoRecovery save of buffer_paper.asdcharlese.C:\BCM550\heapmanagementpaper\buffer_paper.doccharlese5C:\BCM550\heapmanagementpaper\buffer_paper_slides.doc* @h OJQJo(@HP DeskJet 660CLPT1:winspoolHP DeskJet 660CHP DeskJet 660Cpj,,Letter ''''HP DeskJet 660Cpj,,Letter ''''f%@GTimes New Roman5Symbol3& Arial?5 Courier New"@h;f;fP:~SB$0w&COLDFORTH KERNELforth Charles EssoncharleseOh+'0 $0 L X d p|COLDFORTH KERNELdOLDCharles EssonELforths ort Normal.doto charleseto2arMicrosoft Word 8.0@@p@p0@p0~S՜.+,D՜.+,P  hp  Colour Vision Systems Bw&j COLDFORTH KERNEL Title 0nv _PID_GUID _PID_HLINKS descriptionAN{D6914171-897B-11D3-B769-0060083135F2}A,F, joining_buffer.png_( small_buffer.png[9abort_buffer.png0 COLDFORTH uses this file to generate COLDFORTH  !"#$%&'()*+,-./0123456789:;<=>?@BCDEFGHIKLMNOPQSTUVWXY\Root Entry Fk0^0^Data D1TableAuWordDocument-:SummaryInformation(JDocumentSummaryInformation8. RCompObj 5 Y jObjectPool .^0^0  FMicrosoft Word Document MSWordDocWord.Document.89q./version081/heapmanagementpaper/forth.css0100777000000000000000000000100007300314366017466 0ustar rootrootBODY {background: #FFFFFF; margin-left: 1cm} H1 {font-size: 24pt; font-family: mistral; color: #808000; text-align: center} H2 {font-size: 24pt; font-family: mistral; color: #808000; margin-top: .5cm} H3 {font-size: 18pt; font-family: mistral; color: #808000; margin-top: .5cm} P {font-size: 12pt; font-family: arial; color: #303030; text-indent: 0cm} STRONG {font-size: 12pt; font-family: arial; color: #303030; font-weight: bold} CODE {font-size: 10pt; font-family: Courier New; color: #800000; } ./version081/heapmanagementpaper/heap_control.html0100777000000000000000000011563007300314366021214 0ustar rootroot COLDFORTH KERNEL license

Heap control

If you are going to support TCP/IP you need good heap allocation. There is no ultimate heap control method. Just tradeoffs. This version is written in FORTH so it is portable. Supplies buffer according to size of memory requests. Maintains the buffers in sorted lists. Uses a low priority task to recombine buffers. 

 
	ABORT 
	TRUE EQU #heap_debug
	??HEX

There are times when buffers and non buffers are linked into list. Buffers can be returned non buffers can't 

 
	: ?buffer  ( addr --flag)
		_#heap_start _#heap_end WITHIN 
	;

BUFFER STRUCTURE

Before the user area there is a system area. This is used to link the buffer into lists that must be maintained for the orderly operation of the system. When a buffer is allocated data about the allocation is stored in this area for use by diagnostic code. It may look like a wasted area but you have no idea how usefull it is at times to know who is claiming the buffers.

The system part of the buffer is arranged 

 
	zero
		\ linked through here at all times
		\ either through a buffer list or from 'buffer
		\ Unless you use get_free_buffer,
		\ then it is your problem.
		\ Note ALLOCATE and FREE use _get_abort_buff. 
	 DUP CONSTANT _#sys_buffer_link       CELL+
		\ used when linked into abort list.
	 DUP CONSTANT _#sys_buffer_back       CELL+ 
		\ link back to used head
	 DUP CONSTANT _#sys_buffer_used_link  CELL+  
		\ points back to whoever is linked to us
	 DUP CONSTANT _#sys_buffer_used_back  CELL+  
		\ A list offset.
	 DUP CONSTANT _#sys_buffer_size_code  CELL+  
		\ contains task user_base address
		\ or a user code if interrupt code claimed it.
	 DUP CONSTANT _#sys_buffer_task       CELL+  
		\ ip when buffer claimed                                       
	 DUP CONSTANT _#sys_buffer_ip         CELL+ 
		\ pointer that contains pointer to this buffer
		\ on an abort this pointer is reset
	 DUP CONSTANT _#sys_abort_buffer_pointer CELL+
	 	\ time buffer was claimed
	 DUP CONSTANT _#sys_buffer_xclock+    CELL+  
		\ address supplied to user
		\ points here. 
		\ To get the buffer list use the code
		\ buff [ _#sys_buffer_size _#sys_buffer_user - ] LITERAL + @
		\ To convert the list to size see below.
	 DUP CONSTANT _#sys_buffer_user              
                                            
	DROP

The following constant gives the smallest buffer that the system can allocate. We use _#sys_buffer_user in the calculation so that additional fields can be allocated into the system data area and things just sort themselves out. We make sure the result is greater than 10h hex other wise it really is a waste of time going so small. 

 
	40  CONSTANT _#buffer_unit
	_#buffer_unit _#sys_buffer_user - CONSTANT _#min_buffer
	
	\ make sure it is not too small.
	_#min_buffer 0F ??>

We could have written the code assuming the the link into the empty buffer list was offset from the base address but we didn't so make sure it is where we expect it. 

 
	_#sys_buffer_link 0 ??=

BUFFER SIZES

You have buffers that are: _#min_buffer + ( list**2 -1 )( _#sys_buffer_user + _#min_buffer ) bytes long. That is to say you only need one header. The larger buffers are sized so the system can break then into smaller buffers if required. The reconstruction of buffers is done by a background task and is not an application problem. There is a seperate list for each size. The backgroung task joins ajoining buffers and moves them up a list. The number of lists is given by _#sys_buffer_size_code_number , but for the user this is converted into a buffer size and supplied as #maximum_buffer .

Initially I wanted to be able make the smallest buffer any size I wanted, and arrange things so the buffer used for a string was optimized. Unfortuatly the code to determine if two buffers could be joined was a little complex and I went back to binary powers. This makes this calculation more complex than it need be, but it is correct. 

 
	zero
	CREATE _#buffer_sizes                     \ we want this to be resonable fast so pre calc
	1+      _#min_buffer t,                                           \ list 0    number 1
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 00001 * + t,  \ list 1           2
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 00003 * + t,  \ list 2           3
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 00007 * + t,  \ list 3           4
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 0000F * + t,  \ list 4           5
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 0001F * + t,  \ list 5           6
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 0003F * + t,  \ list 6           7
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 0007F * + t,  \ list 7           8
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 000FF * + t,  \ list 8           9
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 001FF * + t,  \ list 9           10
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 003FF * + t,  \ list 10          11
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 007FF * + t,  \ list 11          12
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 00FFF * + t,  \ list 12          13
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 01FFF * + t,  \ list 13          14
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 03FFF * + t,  \ list 14          15 1meg
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 07FFF * + t,  \ list 15          16 2meg
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 0FFFF * + t,  \ list 16          17 4meg
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 1FFFF * + t,  \ list 17          18 8meg
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 3FFFF * + t,  \ list 18          19 16meg
	1+      _#min_buffer _#min_buffer _#sys_buffer_user + 7FFFF * + t,  \ list 19          20 32meg

The above code generates a table of fixed length. The number of entries used depends on the amount of memory given to the buffering system. As a couple of dynamic ram chips can give a sysem a very large area of memory the allocated area can be quite large. 

 
	_#heap_end _#heap_start -                \ amount of memory available
	_#min_buffer _#sys_buffer_user + /       \ number of small buffers that will fit
	>asl 1+  MIN CONSTANT _#sys_buffer_list_number
maximum_buffer

Give the application a hint as to what it can expect. As there is only one buffer of the size #maximum_buffer even in a lightly loaded system it's use is not recommended 

 
	1 _#sys_buffer_list_number 1 - LSHIFT 1 - 
	_#sys_buffer_user _#min_buffer + * _#min_buffer +
	CONSTANT #maximum_buffer

The user should not use size codes, they may change with time. This word converts a buffer size into the internal size code. The size code is a list table offset. There are several list tables, we can use the offset to select the correct list from any. 

  
	\ If the size request is stupid return largest list
	: _size>size_code ( n  -- list_number*CELL )
		#maximum_buffer MIN
		_#buffer_sizes BEGIN
			2DUP @			\ n list n value <--
			1+ < IF ( will fit)
				NIP		         	\ list <--
				_#buffer_sizes -    \ list number by CELL size
				EXIT
			THEN
			CELL+
		AGAIN
	;
buffer_too_big?
 
	\ flag is true if request is bigger than largest buffer
	: buffer_too_big? ( n -- flag )
		\ pick a size that is likly to succeed 
		_size>size_code  [ _#sys_buffer_list_number 3 - CELLS ]T LITERAL > 
	;
n>buffer_size

If you request a buffer of size n the system will return a buffer of size n1. The system deals in buffers of a particular size. It does this so the buffers can be rejoined after use. This word can be used to determine the actual buffer size. This is useful if you are using the buffer to store small units of data and your requested size was about what you wanted.

I think it is better to use buffer_size. 

 
	\ If you make a request for n bytes, what is the actual buffer size.
	\ can be used by programs that use only COLDFORTH but hardly portable
	: n>buffer_size ( bytes -- n2 )
		_size>size_code _#buffer_sizes + @ ;

LIST ARRAYS

The first list in the array contains unused buffers of the smallest size. The second a list of buffers twice as big and so on. Buffers in the unused list are double linked. This is required by the buffer joining code which must be able to join two buffers from anywhere within the list. 

                           
	ram_create _sys_buffer_list_free  _#sys_buffer_list_number CELLS  ram_allot

This is only used by buffer display words. It has to be double linked so that buffers being returned can be returned with just a buffer reference. 

 
	ram_create _sys_buffer_list_used _#sys_buffer_list_number CELLS  ram_allot

RETURNING BUFFERS

To make buffer joining faster the buffer lists are maintained in sorted order. They are sorted from lowest address to highest highest. At first glance this may seem very slow, but remember buffers are taken from and put back on the same end of the list. The correct location is probable going to be near the beginning. Also remember we have a task that aims to keep these lists short. 

 
	\ This is also used in the splitting buffer code, and joining buffer code.
	: _return_buffer ( buffer list --)
		_lock_word
			BEGIN
				2DUP      \ buffer list buffer list <--
				@		  \ buffer list buffer (list) <--
				\ Use unsigned as comparing memory addresses 
				U< IF     \ belongs before this
					\ buffer list <--
					DUP @ \ buffer list (list) <--
					jump  \ buffer list (list) buffer <--
					!     \ buffer list <--
					!     \ <--
					_unlock_word
					EXIT
				THEN
				\ buffer list <--
				DUP @ not IF \ end of list insert anyway
					DUP @    \ buffer list (list) <--
					jump     \ buffer list (list) list <--
					!
					!
					_unlock_word
					EXIT
				THEN   \ buffer list <--
				@      \ buffer (list) <--
			AGAIN
	;

	ram_variable %bad_buffer_address
	: _return_buffer_to_list ( addr_sys --)
		[ #heap_debug [IF] ]T
		DUP ?buffer not IF
			%bad_buffer_address !
			TRUE ABORT" Task returning bad buffer"
		THEN
		[ [THEN] ]T
		DUP					      \ addr_sys addr_sys <--
		_#sys_buffer_used_link +  \ addr_sys link_addr <--
		unlink_double
		DUP _#sys_buffer_size_code + @ _sys_buffer_list_free +
                                  \ addr_sys list <--
		_return_buffer
	;

ALLOCATION OF THE INITIAL DATA AREA

Given addr and length consume memory area and allocate to buffers until all memory consumed This word is used in the init code to set up the buffer system.

We need to make a small note here. This word will create buffers that can't be rejoined, but there will be buffers in the lower list that can be used to create the original buffer if a better option was available.

Example: base 350000 size 30000
Allocated as buffers
350000 size 20000
370000 size 10000
After spliting and joining
350000 size 10000
360000 size 20000
 
	: _init_buffers ( addr length --)
		BEGIN
			DUP _#buffer_unit               \ addr length length size<--
			/                               \ addr length num  <--
			>asl                            \ addr length size_code <--
			[ _#sys_buffer_list_number 1 - ]T LITERAL
			MIN                             \ can have multiple buffers in largest list
			jump                            \ addr length size_code addr <--
			OVER                            \ addr length size_code addr size_code <--
			CELLS                           \ addr length size_code addr list_code <--
			_sys_buffer_list_free +         \ addr length size_code addr list <--
			_return_buffer                  \ addr length size_code <--
			2**                             \ addr length size_code2 <--
			_#buffer_unit *                 \ addr length consumed_length <--
			TUCK                            \ addr consumed_length length consumed_length <--
			2SWAP +							\ length consumed_length addr2 <--
			-rot                            \ addr length consumed_length <--
			-                               \ addr length2 <--
			DUP _#buffer_unit <             \ addr length2 flag <--
		UNTIL
		2DROP
	;

JOINING BUFFERS

This word is used in the low priority task to rejoin buffers. We need to talk about this a bit. To join a buffer we look down the list and find two buffers next to each other that can be joined. The data that must be valid is a pointer to the first buffer, the first buffer and second buffer. The data is collected with interrupts disabled, the interrupts are reenabled, and the data looked at to see if what we want. If it is, interrrupts are disable again, and a check is done to see that the data is still valid. If the data is still valid then the section of the list being looked at is reasonable stable, and a join can occure. Doing it this way reduces the number of wasted joins. 

 
	: _(join_buffers)  \ ( list (list) ((list)) list_number --)
		>R                                 \ list (list) ((list)) <--
		SWAP ROT                           \ ((list)) (list) list <--
		R@ CELLS _sys_buffer_list_free +   \ ((list)) (list) list list_n <--
		_lock_word
		BEGIN
			\ ((list)) (list) list list_n <--
			DUP 
		WHILE \ while there are buffers
										\ ((list)) (list) list list_n
			2DUP = IF					\ ((list)) (list) list list_n <--
				\ this is where we looked befor
				@                       \ ((list)) (list) list (list_n) <--
				jump = IF    
					\ ((list)) (list) list <--
					jump    \ ((list)) (list) list ((list)) <--
					jump    \ ((list)) (list) list ((list)) (list) <--
					@       \ ((list)) (list) list ((list)) ((list)) <--     
					= IF
						\ ((list)) (list) list <--
						\ things have stayed the same
						\ do what has to be done
						ROT     \ (list) list ((list)) <--
						@       \ (list) list (((list))) <--
						SWAP    \ (list) (((list))) list <--
						!       \ (list)
						_unlock_word
						R> 1+ CELLS _sys_buffer_list_free +
						_return_buffer
						EXIT
					THEN
				THEN
				_unlock_word
				DROP
				2DROP
				r>drop
				EXIT
			THEN	 
			\ ((list)) (list) list list_n <--
			2DUP < IF \ gone past no luck give up
				_unlock_word
				2DROP
				2DROP
				r>drop
				EXIT
			THEN
			@
		REPEAT
		_unlock_word
		2DROP	\ ((list)) (list) <--
		2DROP   \ <--
		r>drop
	;

Buffers can only be joined if they create buffers that can be joined.

The theory: A buffer is joinable if the second buffer has bit set in a bit position one lower than the lowest bit position in the first. If you do an XOR this bit position should come up set. The result should be equal to the memory block size of the list. 

 
	\ Now could you ask for a neater solution.
	: _?joinable ( addr1 addr2 list_number --addr)
		jump              \ addr1 addr2 list addr1 <--
		ROT               \ addr1 list addr1 addr2<--
		XOR               \ addr1 list xor<--
		_#buffer_unit ROT \ addr1 xor #buffer_unit list
		LSHIFT            \ addr1 xor list_bit<--
		TUCK              \ addr1 list_bit xor list_bit<--
		=                 \ addr1 list_bit flag<--apart by buffer unit
		-rot              \ flag addr1 list_bit<--
		\ the list bit should not be set in the first address
		AND               \ flag flag<--
		not               
		AND               \ flag<-
	;
addr1 -- buffers have to be below this address
list_number -- size code we are joining
addr2 -- where to start from next time 
 
	: _join_buffer ( addr1 list_number -- addr2 false | true)
		\ addr1 list_number <-
		\ Trace down list until we point to a buffer whose address is above addr1
		dup>r
		CELLS _sys_buffer_list_free +  \ addr1 list <--
		_lock_word
		\ loop around until the pointer points past addr1.
		BEGIN
			DUP @ 
			\ if non zero fetch again
			\ can't join if there are not two buffers
			DUP IF 
				@
			THEN
		WHILE
			OVER    \ addr1 list addr1 
			OVER @	\ addr1 list addr1 (list) <--
			\ addr1 is less than where the list points
			\ Have to used unsigned compare as we are dealing with addresses
			U<       \ addr1 list flag <-- 
			IF ( next buffer is above minimum address, deal with it.
						\ addr1 list <--
				DUP @	\ addr1 list (list) <--
				DUP @   \ addr1 list (list) ((list)) <--
				_unlock_word
				\ addr1 list (list) ((list)) <--
				\ (list) and ((list)) are the address of the two buffers
				\ that we would like to join.
				2DUP R@ _?joinable IF
					3DUP R@ _(join_buffers)
					\ whatever happens we have to move past
					\ and try again.
					\ ((list)) is no longer a link address
					\ just an address we must work above.
					NIP
					NIP
					NIP
					r>drop
					FALSE  \ don't terminate
					EXIT
				ELSE
					\ addr1 list (list) ((list)) <--
					\ we have to move up to (list)
					\ and try again
					DROP
					NIP
					NIP
					FALSE   \ don't terminate
					r>drop
					EXIT
				THEN	
			ELSE
				@   \ addr1 (list) <--
			THEN	
		REPEAT
		_unlock_word
		2DROP
		r>drop
		TRUE  \ terminate
	;
	 
 
	\ This word is suitale for use in a task.
	: _join_buffer_code ( --)
		[ _#sys_buffer_list_number 1 -  ]T LITERAL zero DO
			zero 
			BEGIN
				\ loop until list finished.
				\ _join_buffer returns where we are up to.
				I _join_buffer
			UNTIL
			xpause
		LOOP
	;

SPLITTING BUFFERS

The system has the buffers stored in a series of lists. The next highest list contains buffers twice as big as the list below. If a new buffer is required we go to the next list and split a buffer into two and pu both in the list that has run out. Of couse the next list may not have the required buffer so a call to the next is required and so on. To make matters harder, this has to happen with multiple tasks requesting buffers, and in a manner that doesn't lock up the system for long. This code is written so the a split can successful yet when you go to use your new buffer some other task has pinched it, so you hae to go and split again.

If we require a split of the biggest buffer and there is nothing there, we have problems, If we where running under another OS we could request more memory. In a stand alone system that is the end of the show. We just turn on the led and exit 

 
#BCM550 [IF]
	: _no_buffer_led ( --)
		_lock_word
		_breg_SS1 C@
		_#SS1_no_buffer_memory OR
		_breg_SS1 C!
		_unlock_word
	;
[THEN]
#BVP5502 #BVP5501 + [IF]
	: _no_buffer_led ( --)
	;
[THEN]
_number_in_list

Number of items in a zero terminated list. 

  
	: _number_in_list ( addr -- n )
		zero SWAP
		BEGIN
		    @ ?DUP
		WHILE
		    SWAP 1+ SWAP
		REPEAT
	;
panic.buffers ( --)

Print out the current buffer structure, for what is all means see heap control". 

 
	: panic.buffers ( --)
		panic_cr
		panic"     Size      Free      Used" panic_cr   
		_#sys_buffer_list_number CELLS zero DO
			 I _#buffer_sizes + @ .panic
			 BL panic_emit BL panic_emit
			 I _sys_buffer_list_free + _number_in_list .panic
			 BL panic_emit BL panic_emit
			 I _sys_buffer_list_used + _number_in_list .panic
			 panic_cr
		4 +LOOP
	;
	 
 
	: _get_major_buffer ( --)
		_no_buffer_led
		panic" Ran out of free buffer space"
		panic.buffers
		\ if we came here by ALLOCATE the correct
		\ action is to ABORT
		\ If the problem occured in interrupt code and the 
		\ abort gets back to the system the interrupt task will exit.
		\ as ALLOCATE catches the abort the result is user defined.
		ABORT" Ran out of free buffer space"
	;

This word will take a buffer out of the requested list ( if one is available) and create two buffers in the next lower list. It is used in following words to split a buffer.

On success return with list-1 and true.
On failure return with "list" and false.

The stack items are as required to run _spit_buffer in a recursive manner. 

 
	: _split_buffer ( list_num*cell -- list false| list-1 true)
		DUP _sys_buffer_list_free +  \ list free <--
		_lock_word
			DUP @ not IF \ no buffer to split
				DROP     \ list <--
				_unlock_word
				FALSE
				EXIT
			THEN
			DUP @ \ list free (free) <--
			2DUP  \ list free (free) free (free) <--
			@     \ list free (free) free ((free)) <--
			SWAP  \ list free (free) ((free)) free <--
			!     \ list free (free) <--
		_unlock_word
		ROT      \ free (free) list <--
		cell -    \ free (free) list-1 <--
		_#buffer_sizes + @ \ free (free) size-1 <--
		_#sys_buffer_user + \ free (free) offset <--
		OVER               \ free (free) offset (free) <-- 
		+                  \ free (free) (free+1) <--
		jump cell -        \ free (free) (free+1) free-1 <--
		_return_buffer     \ free (free) <--
		SWAP cell -        \ (free) free-1 <--
		TUCK			   \ free-1 (free) free-1
		_return_buffer
		_sys_buffer_list_free -
		TRUE
	;

The input parameter is the list requiring the extra buffers. The output paramter is the same.

Although this seems like a bunch of dirty tricks it is the best way to do it, this will work in a system that has others pinching the results of our efforts. You can get the case where it will recurse succeed, unrecurse only to have to do it again because someone else has pinched the result. To put it another way when thinking about this code remember others ( including interupt code ) can be running it at the same time. 

 
	??HEX
	: _get_more_buffers ( list*cell1 -- list*cell1)
		CELL+ DUP
		[ _#sys_buffer_list_number CELLS ]T LITERAL < not IF
			\ can't meet request
			_get_major_buffer
			\ if we return system has another source of 
			\ memory. A standard COLDFORTH system does not
			cell - 
			EXIT
		THEN
		BEGIN
			_split_buffer IF ( success)
				EXIT
			THEN
			\ we have failed
			\ we have to call ourselves again to
			\ try the next size up
			RECURSE
			\ if we get back here
			\ we recursed and the recurse worked
			\ we have list where it was and there may now be a buffer in the list
		AGAIN
	;

Have a try at claiming a buffer from the requested list. Failure simple means we have to split a buffer form the next list. 

 		
	: _try_list ( list_number*cells -- list false | addr_sys true) 
		DUP _sys_buffer_list_free +  \ list free <--
		_lock_word
			DUP @ IF  ( we have a buffer)
				DUP @                \ list free (free) <--
				TUCK                 \ list (free) free (free) <--
				@					 \ list (free) free ((free)) <--
				SWAP                 \ list (free) ((free)) free <--
				!                    \ list (free) <--
				_unlock_word
				\ store diagnostic data
				2DUP                                   \ list (free) list (free) <--
				_#sys_buffer_size_code + !              \ list (free) <--
				user_base OVER _#sys_buffer_task + !       \ list (free) <--
				xclock+ @ OVER _#sys_buffer_xclock+ + ! \ list (free) <--
				\ Now have to link into used list
				\ we maintain a back pointer to speed 
				\ up the return operation.
				\ We maintain a used list so we can see what is happening.
				\ nothing more.
				DUP                                    \ list (free) (free)
				_#sys_buffer_used_link +                \ list (free) link <--
				ROT                                    \ (free) link list <--
				_sys_buffer_list_used +                \ (free) link head <--
				link_double
				TRUE
				EXIT
			THEN  
		( we have failed
		_unlock_word
		DROP                     \ list <--
		FALSE                    \ list false <--
	;


	\ note we do not check that the stack item:  list  is valid
	\ unless we have to get more buffers.
	: _get_buffer_from_list ( list_number*cells -- addr_sys)
		BEGIN
			_try_list              \ list flag<--
			IF 
				EXIT 
			THEN
			\ if we get here list was empty
		    _get_more_buffers                   \ list <--
		AGAIN
	;

MISCELLANEOUS

buffer_save_ip

When a buffer is claimed a ip value that points to who did the claiming should be stored in the buffer system area. This word should be used at a level where a valid ip value is known. Where that is will depend on how the buffer is claimed.

This needs to be done at different places in different words applications are free to use this if they create generic memory allocation code. It will seldem get used but users needs access to this word 

 
	: buffer_save_ip ( ip addr_user )
		[ _#sys_buffer_ip _#sys_buffer_user - ]T LITERAL + ! 
	;


	\ when starting up tasks buffers are claimed for the new task
	\ The task using the buffer is really the new task and this should
	\ be indicated
	: buffer_save_task ( u addr_user
		[ _#sys_buffer_task _#sys_buffer_user - ]T LITERAL + ! 
	;

The application words

buffer

The user area has a variable ( uvariable) called 'buffer. In this variable is stored the user address of the last allocated buffer. 

 
	: buffer ( --addr_user )
		'buffer @ 
	;
get_buffer

get_buffer and kill_buffer can be used to get and release a fresh buffer that is pointed to by 'buffer and refered to using buffer . These words must be used together. 

Example:
    n1 get_buffer                     \ buffer 1
         buffer                       \ address buffer 1
         n2 get_buffer                \ buffer 2           
		 buffer                   \ buffer 2
         kill_buffer
         buffer                       \ buffer 1
    kill_buffer

The buffers are linked together in the buffers system area so get_buffer can be used recursivly. ABORT releases the buffers back to the system. In other words you get access to the buffers but the system knows where they are. Buffers so allocated will be returned on a task abort. 

 
	??HEX
	: get_buffer ( n --)
		_size>size_code                 \ list_number*cells <--
		_get_buffer_from_list           \ addr_sys <--
		buffer 
		OVER !                                                        \ addr_sys <--
		[ _#sys_buffer_user _#sys_buffer_link - ]T LITERAL +          \ addr_user <--
		'buffer !
		R@ buffer buffer_save_ip
	;
kill_buffer
 
	: kill_buffer ( --)
		buffer IF
			buffer [ _#sys_buffer_link _#sys_buffer_user - ]T LITERAL + DUP @  \ addr_sys addr_sys1 <--
			'buffer !                                                          \ addr_sys <--
			_return_buffer_to_list
		THEN
	;

	\ used in ABORT to return all buffers
	: _return_buffers
		BEGIN
			buffer 
		WHILE
			kill_buffer
		REPEAT
	;

The following words are supplied to the user as ALLOCATE and FREE, two standard ANS words. 

 
	: _get_abort_buffer ( pointer n --addr_user)
		_size>size_code                  \ pointer list_number*cells <--
		_get_buffer_from_list            \ pointer addr_sys <--
		DUP _head_abort_buffers link_double	 \ pointer addr_sys <--
		TUCK                             \ addr_sys pointer addr_sys
		[ _#sys_abort_buffer_pointer _#sys_buffer_link - ]T LITERAL + !
		[ _#sys_buffer_user _#sys_buffer_link - ]T LITERAL + \ addr_user <--
	;
	 
 

	: _kill_abort_buffer ( addr_user --)
	    ?DUP IF
		    \ reset location pointing to buffer if we have been asked to
			DUP [ _#sys_abort_buffer_pointer _#sys_buffer_user - ]T LITERAL + @ ?DUP IF
				zero SWAP !
			THEN
		    [ _#sys_buffer_link _#sys_buffer_user - ]T LITERAL +
			DUP unlink_double
		    _return_buffer_to_list
	    THEN
	;

The cell pointed to by addr is set to zero on an abort. The cell should be used by the application to store the buffer address. This word is required because ALLOCATE is a standard word and it doesn't allow the setting of a pointer address. 

 
	: set_abort_buffer_pointer ( addr addr_user --)
		[ _#sys_abort_buffer_pointer _#sys_buffer_user - ]T LITERAL + ! 
	;

This is used in the abort routine 

 
	: _return_abort_buffers ( --)
		BEGIN
			_head_abort_buffers @ ?DUP
		WHILE

			[ _#sys_buffer_user _#sys_buffer_link - ]T LITERAL +
			_kill_abort_buffer
		REPEAT
	;

Use these to get buffers that are not linked into 'buffer or 'abort_buffer. If you store the address somewhere and do not set it back to zero on an abort these are the words for you. Better to use ALLOCATE and FREE for general work These completly remove the buffer from the buffer system. A good idea if you are transfering buffers between tasks. But the buffers can be lost if something goes wrong. 

 
	: get_free_buffer ( n -- addr_user)
		_size>size_code                                      \ list_number*cells <--
		_get_buffer_from_list                                \ addr_sys <--
		[ _#sys_buffer_user _#sys_buffer_link - ]T LITERAL + \ addr_user <--
		R@ OVER buffer_save_ip                               \ addr_user <--
	;
	 
 
	: kill_free_buffer ( addr_user --)
		?DUP IF
			[ _#sys_buffer_link _#sys_buffer_user - ]T LITERAL +
			_return_buffer_to_list
		THEN
	;
#$buffer

1 for the count 1 so we can zero terminate 0FF for the characters then round up to nearest long word AS the buffer system works as it does the buffer retuned will be longer. 

 
0FF CONSTANT #$maximum_data
104 CONSTANT #$buffer
$buffer

Use this to get buffers for counted strings 

 
	: $buffer  ( --)
		#$buffer get_buffer
		\ we want to know who called us
		R@ buffer buffer_save_ip
	;
buffer_size

Best way to go is ask for about what you want and then use this word to see what you got ( it will be bigger or the same) and then use what you get. 

 
	: buffer_size ( addr_user -- size )
		DUP 0= ABORT" Buffer address supplied as zero"
		[ _#sys_buffer_size_code _#sys_buffer_user - ]T LITERAL + @ \ size_code <--
		_#sys_buffer_list_number CELLS                            \ size_code size_code_max <--
		OVER < ABORT" Buffer structure faulty"
		_#buffer_sizes + @
	;

ANS MEMORY ALLOCATION

get_buffer and free_buffer are simpler to use as recursive use of buffer is possible. They are not portable.

ANS 14.6.1.0707 ALLOCATE

MEMORY

( u -- a-addr ior )

Allocate u address units of contiguous data space. The data-space pointer is unaffected by this operation. The initial content of the allocated space is undefined. If the allocation succeeds, a-addr is the aligned starting address of the allocated space and ior is zero. If the operation fails, a-addr does not represent a valid address and ior is the address of a string describing the error. 

 
	CREATE _$too_big  ," buffer request too large."
	: ALLOCATE ( n -- addr_user ior )
		DUP buffer_too_big? IF
			DROP zero _$too_big EXIT
		THEN
		\ ALLOCATE doesn't know where the address will be stored.
		\ so set ponter to zero
		zero SWAP				   \ pointer n <--
		['] _get_abort_buffer CATCH ?DUP IF \ failed
			NIP       \ zero $error<-- 
			EXIT
		THEN     \ addr<--
		R@ OVER buffer_save_ip
		zero     \ addr i/o_error<--
	;
ANS 14.6.1.1605 FREE

( a-addr -- ior )

Return the contiguous region of data space indicated by a-addr to the system for later allocation. a-addr shall indicate a region of data space that was previously obtained by ALLOCATE or RESIZE. The data-space pointer is unaffected by this operation. If the operation succeeds, ior is zero. If the operation fails, ior is the implementation-defined I/O result code. 

 
	: FREE ( addr_user -- ior )
		\ never fails.
		_kill_abort_buffer zero
	;
ANS 14.6.1.2145 RESIZE

( a-addr1 u -- a-addr2 ior )

Change the allocation of the contiguous data space starting at the address a-addr1, previously allocated by ALLOCATE or RESIZE, to u address units. u may be either larger or smaller than the current size of the region. The data-space pointer is unaffected by this operation.

If the operation succeeds, a-addr2 is the aligned starting address of u address units of allocated memory and ior is zero. a-addr2 may be, but need not be, the same as a-addr1. If they are not the same, the values contained in the region at a-addr1 are copied to a-addr2, up to the minimum size of either of the two regions. If they are the same, the values contained in the region are preserved to the minimum of u or the original size. If a-addr2 is not the same as a-addr1, the region of memory at a-addr1 is returned to the system according to the operation of FREE.

If the operation fails, a-addr2 equals a-addr1, the region of memory at a-addr1 is unaffected, and ior is the implementation-defined I/O result code. 

 
	: RESIZE        ( addr_user1 n1 -- addr_user2 ior)   
		DUP buffer_too_big? IF 
			DROP      \ addr_user1 <--
			_$too_big EXIT 
		THEN
		\ If the request can fit in a smaller buffer do so.
		OVER buffer_size   \ addr_user1 n1 current_buffer_size<--
		OVER n>buffer_size \ addr_user1 n1 current_buffer_size proposed_buffer_size<-- 
		= IF            \ memory request is for same size buffer
			DROP zero EXIT
		THEN \ addr_user1 n1 <--
		zero SWAP                    \ addr_user1 zero n1 <--
		['] _get_abort_buffer CATCH  ?DUP IF  \ error occured
			NIP NIP                  \ addr_user1 $error<--
			EXIT
		THEN
		                             \  addr_user1 addr_user2 <--
		2DUP                         \  addr_user1 addr_user2 addr_user1 addr_user2 <--
		OVER buffer_size
		OVER buffer_size
		MIN                          \  addr_user1 addr_user2 addr_user1 addr_user2 size <--
		MOVE                         \  addr_user1 addr_user2<--
		SWAP
		FREE
	;

ubuffer

Used in the form:

n ubuffer name

Where n is the size of the buffer required. ubuffer is the parent and name is the child. The child returns the address of a buffer. The address is stored in a user variable so the same word returns different addresses in different tasks. The buffer is linked into the _'abort_buffer list. In other words buffers allocated with ubuffer child words will be taken from the buffer pool as and when the data is used. The buffers will be returned on an abort. If the buffer must survive across aborts use ufree_buffer.

Describe the dictionary entry 

 
	zero
	DUP CONSTANT   _#ubuffer_uoffset CELL+
	DUP CONSTANT   _#ubuffer_n       CELL+
	DROP

This is an extension to the cross compiler. 

 
	: user_buffer_runtime
		DUP [ _#ubuffer_uoffset ]T LITERAL + @ @u + @ ?DUP IF \ buffer allocated
			NIP EXIT
		THEN
		DUP [ _#ubuffer_uoffset ]T LITERAL + @ @u + 
		OVER [ _#ubuffer_n ]T LITERAL + @              \ pfa pointer n <--
		_get_abort_buffer                  \ pfa addr_buffer <--
		TUCK SWAP                          \ addr_buffer addr_buffer pfa <--
		2DUP SWAP buffer_save_ip           \ point to the guilty party
		\ set the user variable to the buffer address
		[ _#ubuffer_uoffset ]T LITERAL + @ @u +      
		                                   \ addr_buffer addr_buffer user <--
		!                                  \ addr_buffer<--
		\ preset to zero
		DUP DUP buffer_size ERASE
	;

	forth : ubuffer ( n--) 
		HOST  CREATE
		HOST  'U             \ n addr <--
		forth @              \ n offset <--
		HOST  t,             \ n <--
		forth cell
		HOST  'U
		forth +!
		HOST  t,              \ <--
	DOES>
		user_buffer_runtime
	;
	
	\ allocate a ubuffer that doesn't get returned on an abort
	: user_free_buffer_runtime
		DUP [ _#ubuffer_uoffset ]T LITERAL + @ @u + @ ?DUP IF \ buffer allocated
			NIP EXIT
		THEN
		DUP [ _#ubuffer_n ]T LITERAL + @              \ pfa n <--
		get_free_buffer                  \ pfa addr_buffer <--
		TUCK SWAP                          \ addr_buffer addr_buffer pfa <--
		2DUP SWAP buffer_save_ip           \ point to the guilty party
		\ set the user variable to the buffer address
		[ _#ubuffer_uoffset ]T LITERAL + @ @u +      
		                                   \ addr_buffer addr_buffer user <--
		!                                  \ addr_buffer<--
		DUP DUP buffer_size ERASE
	;

	forth : ufree_buffer ( n--) 
		HOST  CREATE
		HOST  'U             \ n addr <--
		forth @              \ n offset <--
		HOST  t,              \ n <--
		forth cell          
		HOST  'U 
		forth +!
		HOST  t,              \ <--
	DOES>
		user_free_buffer_runtime
	;
./version081/heapmanagementpaper/joining_buffer.png0100777000000000000000000000737707300314366021355 0ustar rootrootPNG  IHDR3 PLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4D IDATx흁8%^YgZws].+SK5Xt*l:6 N,,?OGk-k+r9D[Mypn? /]t>?ؖ[)|uJɶܵ9^t!95;':]v-az&.f>n> [6-] tGYqlZ뿓ν츗=V|^ܞYN 6QÄ> S_ >6hnwEґos۾әvb3(lsm=98ߴfeu^g}c=<+7˟mQ|qͫe{dwPL^wF?36[ ?L&͜z1l_lh{NSbmsݓ+{f*Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V*ARDl!Kfr_ 9C)،f6`wlYK6f2polY fQ)\d^3R¦Saөd{0&Rfe ,.l}:EPS@6U>f") }NŅMվYj ¦jǬS5dqaSc)1AMY\Tu,.l}:EPS@6U>f") }NŅMվYj ¦jǬS5dqaSc)1AMY\\iw&eRt*l: {^^}r=Y`ǬܟVcV-1kuP=<(~B"k}PzH@/cH¦jǬ Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V KжA؜͉X16'bb}s$%6U!(bU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,VŪ6XfBPbU Y Aa3U!(lf*,V%b3@P_6#PjJf=6Ac3ZT96A{c3ZT56uoވJ"S6 NM¦SaөTt*l:6 NM¦SaөTt*l:6 NM¦SaөT˴ni𯟎 NI֩~.F5] \> !M]ds`E&mas_u\K~>b^˛fX;ͻ-&XރgSou篃͟܇"q2:໐:6G16}ul_،B * ag{6M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab N*6@ 9a3丯P }levrܷf96ýo oeoz ?BL7 NM*~߼C 3tĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ab NtĦ$6 M'Hl:Ar$V;6 NM¦SaөTt*l:6?^ZLUIENDB`./version081/heapmanagementpaper/kernel_tasks.html0100777000000000000000000000267307300314366021226 0ustar rootroot COLDFORTH KERNEL license 
 
    ram_variable 'local


	target_also
    &tasks
	target_definitions
  
    #clock_low task: local
		[ #BVP5502 #BVP5501 + [IF] ]T
		$" ty1" 
		[ [THEN] ]T
		[ #BCM550 [IF] ]T
		$" ty0" 
		[ [THEN] ]T
		R/W $open 
		DUP 'output_file !
		DUP 'input_file !
		DUP 'abort_file !
		DROP
   		ws60
		CURSOR send
    	'local @execute xoff 
	;task
	 
  
    #clock_low task: buffer_reclaim
		BEGIN
			xtest 1 xwait
    		_join_buffer_code
		AGAIN
	;task

	#clock_low task: flash_write
		BEGIN
			\ maximum rate once every 100 msec
			xtest #10 xwait
			_%flash_write_queue xawait
    		_write_buffers_to_flash
		AGAIN
	;task


\
\   #clock_medium task: WATCH_TASK
\  	BEGIN  
\   		   watchdog_list watchcheck  xpause
\   	AGAIN
\   ;task
\  

	\ tcp/ip
	\ ------------------
	\ This will route all pending packets and then exit
	#clock_medium task: route_ip
		BEGIN
			_ip_queue xawait
			_route_ip_queue	
		AGAIN
	;task

	target_previous_definitions
	target_previous
./version081/heapmanagementpaper/license.html0100777000000000000000000000405507300314366020157 0ustar rootroot COLDFORTH KERNEL

Copyright (C) Colour Vision Systems 11 Park Street Baccus March Victoria Australia.

You may distribute this file under the GPL, or "Artistic license" as described below.

Artistic license

This file along with other files is used to produce a package. The copyright holders and conditions of use of files differ. The package is free software you can redistribute it and/or modify it under the terms of the Artistic license

The package is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

GPL

This file is free software source; you can redistribute it and/or modify it under the terms of the GNU General Public License Version 2 as published by the Free Software Foundation.

This software source is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more detail.

You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

Intent

If you modify the package to suit your needs, those that have developed the package would like to benefit from your work, as you have benefited from theirs.

If you use the package to develop a program, what you develop is your business.

./version081/heapmanagementpaper/print_system_data.html0100777000000000000000000000621107300314366022262 0ustar rootroot COLDFORTH KERNEL license
.tsk ( --)

Task details. #### This needs a lot of work. 

 
    : .TSK ( task --)
    	@  ( address of task table)
    	DUP @ (  task_table_addr status_addr <-)
    	CR
    	DUP ." user_base: " .h
    	DUP [ (S) user_base - ]T LITERAL + @ (  task_table status stack <--)
    	DUP @ ( old I ) ." I: " .h
    	DUP 4 + @ ( return top) DUP ." R: " .h
    	(  task_table status stack ret <--)
    	( print return stack)
    	CR ." return_stack"
    	jump ( status) OVER - 4 / zero ?DO
    		CR DUP I 4* + DUP .h SPACE @ .h
    	LOOP DROP
    	(  jump task_table status stack <--)
    	CR ." system_stack"
    	8 + ( saved R and I )
 \   	jump _#task_table_s0 + 
    	(  jump task_table status stack+8 base )
    	OVER - 4 / zero ?DO
    		CR  DUP I 4* + DUP .h SPACE @ .h
    	LOOP DROP ( stack)
    	(  jump task_table status <--)
    	2DROP
		send
    ;
.buffers ( --)

Print out the current buffer structure, for what is all means see the file heap_control.html. 

 
	: .buffers ( --)
		CR
		BASE @ >R
		HEX
		."     Size      Free      Used" CR   
		_#sys_buffer_list_number CELLS zero DO
			 I _#buffer_sizes + @  8 .R
			 2 SPACES
			 I _sys_buffer_list_free + _number_in_list 8 .R
			 2 SPACES
			 I _sys_buffer_list_used + _number_in_list 8 .R
			 CR
		4 +LOOP
		R> BASE !
		send
	;

	' .buffers (.buffers) t!
.buffers_used

Print out details of the buffers used. 

 
	: .buffers_used
	   CR
	   BASE @ >R
	   HEX
	   ."   Address       Size      Task      Word"  CR
	   _#sys_buffer_list_number CELLS zero DO
			I _sys_buffer_list_used + @
			BEGIN
				DUP
			WHILE
				DUP [ _#sys_buffer_user _#sys_buffer_used_link - ]T LITERAL +
				8 .R  2 SPACES
				DUP   [ _#sys_buffer_size_code _#sys_buffer_used_link - ]T LITERAL + @ I <> IF
					." Rubbish"
   					DROP zero
   				ELSE                                                                
   					2 SPACES
   					I _#buffer_sizes + @ 8 .R 2 SPACES
   					DUP   [ _#sys_buffer_task  _#sys_buffer_used_link - ]T LITERAL + @
   					8 .R  ( #### .task when written)
   					2 SPACES
   					DUP   [ _#sys_buffer_ip    _#sys_buffer_used_link - ]T LITERAL + @
   					8 .R  ( #### ?.head when written)
					@
				THEN
				CR
			REPEAT
			DROP
		4 +LOOP
		R> BASE !
		send
	;


    
    ( free memory print) HEX
    : .free ( --)
		CR ." Dictionary : " _'h_task_top @  HERE      - 9 .R
		CR ." Ram        : " _'ram_top    @  ram_here  - 9 .R
		CR ." Fast ram   : " _'fast_top   @  fast_here - 9 .R 
		CR
		send  
	;
./version081/heapmanagementpaper/small_buffer.png0100777000000000000000000001273507300314367021023 0ustar rootrootPNG  IHDRfKXOIDATx뚤Ps[rl ֯jTԈO<ϟ?&n@+D@AD@AD@Aٜ󳚒W7߹m?\l ܱL)_ǵz+s0D\_ĭR0@q'8enˉ^g<1eu,W'6CrqQ[,^jEZ^c~ܜ>nЯY#޵*Fn6mf]x赛ZhzcUl ДTF-W.tn ДbAJ*nMYCN" )JLnj97wqsckm{2 "@  "@Ta?$Y/f;`ޭJSuxz? .vCJA S% ~ۈ+_up5.}i87c:+@],nLj<ƹ/η>yzk n6zZP4nZIz3=N߭dxN;](𰓂6逸\`z>I|s^5GF{{}7CL邥.?(֒=jUcYalDㅿJv.tO5܈)NIdٹwk|Gcpоb˟WKNlyXY nL Jr?b ;e\yLܜAX3_2 \yAr &7}1 o ! "@ c%1q8(!JbHӇC:U .$7G1a&bHdǐxU MR/vpAG 3@lLdޜx5Jg&%1)U>dbHtS"s|,s0}3SEa iZ#yRse橆dCL i'#RCΧ\ ig >'uyB;һ=\Vti=xJ =Xq!|ZZƏx29>{N"/:eҾ[̃qIŐ_bꞫ-DBCD@ i&K %bHS|@1dD@AD@ )@PC.tT>uIv lRgQ,G[ͼ~x\Ȃ-7jooZ̸IBiN%ߴꇷtޮ3Đ~ۋ-2vijy}RGY(w1qIt6 Y:Lxww]>3\XkO~ǧɽ鉧RCZ:*F4z(<PS־ÃRbZY3IcH[;? \VKognvL ~}wϠynڊKӞ+U>CpQnT\F:w4 Ne/t-t#Iy}/qwanϠoC?ФկJXz(1JoR*0[;wtok)*ʎ,hҫ|-N!uxQUOWwRR4qQ^rIj^JA|Ek݁F*#)ثw.zh1u?:LR bAta3xC `X@ i&K %$\2 "@  "@  (!M1]`y`u*-=1C'cE_SnӽϺxll!;6rL9{qKnJ}ʜ5Nrgƾtěm.* I?g4d9vV )CzGy8l͝so3w+m[5Lv iSVߐeE@u$nMum~I,,ۗ$K_vτ2<ЈhKu7eǐK!mIX1)ٶ{m;"D !H{7dj(a%C|H IǍ622N{4ł2 2"@ bH;0A]bH/C:瘏s ((R$t9]6iKm4%;tmM t$TcFV(0 /"٤Ut>Gm.ˉɕC:= MZE_qOcV3?sf1MZ]U;qỲcH7&eMblU:8M/"mVÃW>MĐ&Z6ES 'N.XɎ!ݛmMڤGW36v׎8WCƲIŐ^iq\J 闵CE{HƵwiGi\7їg #-3"@ bH;0A]bH/C:瘏s ((R$bDcH/&!%c+cH[;W$R@g!$1mCž>pbHk+tuLspsEa cͯS E'f-G.ŐqCZ`5eJbH!-0ҶǾTseZA*4y_;\T= |~7\ԔZyzyмw9NW%o8*ze}CC8Peۛp#s|7^izܶwWwXv^uY{_ |~os+L݋g^JۛY_Yt߾yΟ2֚ʽ̝9CV:ma23??ӿr]w2@bOue94ݙHzo=9>ITR{ <B7!S.uSnT묊ϖu<;D37?://oNOYW_  W-aO_X?}LAª}C1>6O CzX/{C 9q)Ӈ2'$vwqs|}ͮ}0ݡl0. `uI1~u=|r_2DIC_xhOZT/]Ȼ ǧ"{u[% (zq7kJJxR/{oNEO]>>}7nC쮂H doozC^yqYI.}H[ߍ ^a-X1Խ_L"m- Qk7 ^ 2"@  "@  Cz3%3o5ŭcah)4MI "R yXO/fZ#w ;<8*J!:Q\A0A5EEsuU=|<$]_Ԫ&8u2g3$y\ [^?گ5;{ UʓjH#R/W^We~V+g,ڔM#CR󭖉]Ͻ|<@E'=eԈ L_9U)0F|k:R-/_SU: ekI[xI@-'qo_=xf|`xq(;2Q7ތ<ƴR !Kb*3̣&/kbJbywTы+#d@CQj8 |*ja.S!~Y^/vj©erLEߍFQwlfJe\>o< Of>}|q Ul_ttJ׋ôwfkӑC\)x[G )ˋWlDG*D㒙v/ "R鈂PGږ/Syj"ӽUg,4NABM.ykg 5(BMu " Qy*N(،KQ0(((((((((P.N͐D@AD@ArY4 ; P P6P PuD@9ܧ`ߦd(dD@AD@AD@AD@AD@AwcIENDB`./version081/init/0040744000000000000000000000000007303262422012574 5ustar rootroot./version081/init/nice_setup.html0100777000000000000000000000136607300314375015636 0ustar rootroot COLDFORTH KERNEL license

This file is used to set up the nice interface. It sould be included in the flash file system and altered if required.

On entry the stack contains the nice object address. 

 
\ object<--
\ The interface hardware address
#$nice_default OVER $set_nif
\ the ip address
192.168.255.019 OVER set_ip
\ the mask
$FFFFFF00       OVER set_mask

DROP
./version081/init/routing.html0100777000000000000000000000146507300314375015167 0ustar rootroot COLDFORTH KERNEL license

Datagrams of unkown destination are sent to the default gateway, the default code assumes that this is host 1 on the nice segment. 

 
000.000.000.000          \ ip, anything 
$00000000                \ mask everything
%nice_object @ :ip @ %nice_object @ :@netmask AND
\ change this if you want the gateway to be something other than 1.
001 OR                   \ gateway
$00000040 $00000000 %nice_object @   static_route
./version081/multitaskingpaper/0040755000000000000000000000000007303262414015377 5ustar rootroot./version081/multitaskingpaper/abort_buffer.png0100777000000000000000000001501107300314367020551 0ustar rootrootPNG  IHDR wKPLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4DIDATx흍 F}9D Fтzt%)>pCՄjnVQpQpQPY7sh[ܾmGa(=Apu熿~-ޯ\G3H&R ~$A?mjtZ/S^ޚ(j4B7nO=`j`#3 V) g h51Mw4g%|,i==<7G, ' p f?N=Qca\^GaL2W⚸`cL/XBN$Q'|\۔۠0&d`\ucz@M 2gNe Q[e AZ2CkMŕ9 `KP(_I790 1QdvgygzjB2AY-Q9 RP>T&sb혁n$Kf*r㜀Bn7X8g$yB#Y>у#QڥuL" !Ә 1a(7=%_G}N2VH֜,aA 0X4hS{xw:{3s2scB%=Ȥ+lfA 2xo"s7&2xo"s7&2GFP@ C/ w [Vf{]jNIDsy,X<J75d|@%C`諥)dgin_Gs/YvS'؝AH\okrrWw6#P0ςJf߃mJ*sxśs@7+s2QW8AV{q2 jG,PXԽ 32%> \(e: $9 j/BY0AN(|QE&x|9nU>\E;%P@[ʕw{|B9=, 0^5JW*\ ,Azh)ۻ酂= aj ~=F6ckKg#I8ODѰ+@r1(F='4E&b &I %y댬+hz'$ .r },/n drwma!d{ LĴIZF}  Q5oL_y@TNόdd # e]\6G,Swc$#BY F2(e: Gy(G/0V,LE|+Q{d: Gy(Gp!V[}MN3. c~z(eҕz :B#'l"($d$/FɔΌ.LL*Wq#)TL+-z \ԞY>a$#;WX/_301P@703P$S <ԣc%z'+tDA11BCPF9&+vg+Kˣ'Ǎ fxB !I!}yd >aU-v%{>>ۄ4KU(Bp-࿟5zU~VBȣ4G!s8Ê,}|+|Yf еB# #D>i񍀣P1NIm-ؠP^oP߄‰{d: Gy(G`ܣpCgѲ0#`jޜlEk@3"lD!ޥ-PG!Qд@ƒmnt[K#ܑƛ(sg)@Vq i.NaȼD?hFִK2Ru] Lk)J Wot?5B|{(A!ƧI*;ZLԞ̵f.0 >uMO7»P q@ Q0E!GlisB}+\ m(PkӓRB!̱ w^SxX!=*ߧp2tDWHjmJcOg:B:};Iɩ!V+5 xWvٯK61pG6X`&Q  6,#F  E_Wϩ X !>4(t(UDoQ; uy0>1σ'Q@i;taX|ߓQ: [b0010?Zi$#Y p\(*rK 6Xq)ʚ_:W?֕ ObTm J<%F6< jA]=`XsX!.1!FA$3 ;HG=MN@!5~ e6i$#}2ZpFTm|Fʜ8YYmBYp|3 H>V@G+ Ry2>\~9w ۹7u=UMjAųt2"҂㴒/m՚=UxP# (ur#cQ: YZ 1C$XczJ(Lbdx ]PͲYWm}¾ZLXdT<4Vńu-1f ttm*#Z^"ˈ׌ pl.Whuvx3G!# 9 yas ]^Z7ZL 0G(Xb ZL§-]I~wlI?oGPjĝ`+@;h,.$9 6-_ >&~T]jmK6 |k9P~;dZ{`!+y@ּȺ&m# B~pbj8XxVDaTERճoSg cǩF}WY8fS"3IB˒s95A2(\No *O _`a3&8sso<jB{QY5GM0n;GkFSpSѧ!B{Cʵ'pRY\x|(PwY!BASD?3@0 i pT|b= C}X|<6c\;P@ωqȺBwp4/c&ydR5V}|<6YbR~QiCiGێO6 Qi?IB"Mo(xJ𽭈Osd潂-&Qń9 0G(XbŠ(|Qi%>9 6-W͈?fQP+sF COLDFORTH KERNEL

Copyright (C) Colour Vision Systems 11 Park Street Baccus March Victoria Australia.

You may distribute this file under the GPL, or "Artistic license" as described below.

Artistic license

This file along with other files is used to produce a package. The copyright holders and conditions of use of files differ. The package is free software you can redistribute it and/or modify it under the terms of the Artistic license

The package is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

GPL

This file is free software source; you can redistribute it and/or modify it under the terms of the GNU General Public License Version 2 as published by the Free Software Foundation.

This software source is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more detail.

You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

Intent

If you modify the package to suit your needs, those that have developed the package would like to benefit from your work, as you have benefited from theirs.

If you use the package to develop a program, what you develop is your business.

./version081/multitaskingpaper/multitasking_abstract.html0100777000000000000000000000251607300314367022675 0ustar rootroot CVS FORTH KERNEL

COLDFORTH Multitasking

If a computer is controlling a machine, TCP/IP should have a low priority. Stopping the machine at limit switches, generating a nice function output; they are all things of greater importance. What does it matter if a couple of datagrams are lost, the network has probable dropped some anyway.

COLDFORTH supports preemptive multitasking and places TCP/IP communication priority one level above the lowest level. The lowest level is used for user input. Both levels are below the priority levels used to control machinery.

TCP/IP requires the timeout of routes, the timeout of ARP entries, timeout of defragmentation attempts, and the detection of TCP inaction. All these functions are placed in tasks that sit on the lowest priority level along with terminal input and buffer defragmentation. Getting the data through has a higher priority.

This article looks at why a preemptive multitasking is important and how it is implemented in COLDFORTH.

./version081/multitaskingpaper/multitasking_paper.doc0100777000000000000000000016000007300314367021773 0ustar rootrootࡱ> kmjY IbjbjWW -==E],L\V       !######$RF~G     G   V   ! ! S! :l0 COLDFORTH Multitasking If a computer is controlling a machine, TCP/IP should have a low priority. Stopping the machine at limit switches, generating a nice function output; they are all things of greater importance. What does it matter if a couple of datagrams get dropped, the network has probable dropped some anyway. The whole TCP/IP protocol suite is designed around the assumption that datagram delivery is unreliable. COLDFORTH supports preemptive multitasking and places TCP/IP communication priority one level above the lowest level. The lowest level is used for user input. Both levels are below the priority levels used to control the machinery. TCP/IP requires the timeout of routes, the timeout of ARP entries, timeout of defragmentation attempts, and the detection of TCP inaction. All these functions are placed in tasks that sit on the lowest priority level along with terminal input and buffer defragmentation. Getting the data through has a higher priority. Having a preemptive multitasker allows you to give the plant priority and still enjoy the benefits TCP/IP brings to industrial control. This article looks at why preemptive multitasking is important and how it is implemented in COLDFORTH. Why is time important? If you're using your computer to stop a piece of machinery at a limit switch or to generate time based waveforms; time matters. If you don't stop at the limit switch you run into the end stops. If you make a mess of an analog function generating a speed reference the equipment will not accelerate smoothly placing extra stress on the equipment and occupants. Let's take a closer look at waveform generation. In the real world you create an S curve when generating a speed reference, such a curve limits the jerk ( the derivative of acceleration). For our example we will look at the generation of a simple ramp. The desired function is. INCLUDEPICTURE \d "./ramp.png" If you implement your software well and take a close look at the output you will see what is shown below. INCLUDEPICTURE \d "./ramp1.png" If you schedule badly but take into account the elapsed time, things look good at a distance. The magnified image is an irregular staircase. If this was controlling a DC machine the big steps would represent large current demands, current demands that could lead to equipment failure, or in extreme cases current demands the real world can't deliver. INCLUDEPICTURE \d "./ramp2.png" If you schedule badly, and don't take into account the elapsed time things don't look good even at a distance. As the diagram below shows. INCLUDEPICTURE \d "./ramp3.png" To get the smooth option do I need preemptive multitasking? The sort answer is no. You can do it with no multitasking. If an application programmer was trying to do the job with an OS that supported no multitasking they would simply call the ramp function regularly. : anns_ramp_function whatever_is_required ; : my_function ( --) do_some_of_my_stuff anns_ramp_function do_some_more_of_my_stuff \ forget ann I need to get this job done \ anns_ramp_function and_so_on ; If you do it this way all code has to contain calls to unrelated code. Not a very modular solution, and the reason why many FORTH systems support a single loop multitasker. The sample code them becomes. #clock_low task: anns_ramp_function BEGIN whatever_is_required xpause AGAIN ;task : my_function ( --) do_some_of_my_stuff xpause do_some_more_of_my_stuff \ forget every one else I need \ to get this job done \ xpause and_so_on ; In the FORTH environment switching from one task to the next in a task loop is a simple matter. You push the state of the FORTH environment onto a stack, save the stack pointer into a task specific location and start the next task. COLDFORTH is a subroutine threaded forth that supports local variables and objects. To switch tasks within a loop: Pushes the current local variable pointer onto the data stack Pushes the current object pointer onto the data stack Pushes the return stack pointer onto the data stack Store the current data stack pointer into the tasks user area Active the next task in the loop There are FORTHS that support single loop multitaskers, but don't maintain the local variable and object pointer in registers. These FORTH will switch tasks even faster. The single loop multitasker brings one big advantage. You do not have to know anything about the other functions, you simply exit to the multitasker often, and give others a go. There a two major problems: All tasks have to be nice If the system is overloaded the OS has no idea what is important and what is not. A preemptive scheduler A preemptive scheduler is run by an interrupt source. The interrupt can be anything; a clock, or if your computer is dealing with video images the horizontal sync. Whatever the event, the idea is simple. When the event occurs you suspend the low priority stuff ( which hopefully is where you are at) and start the high priority stuff. It then doesn't matter how the low priority stuff behaves. Preemptive multitasking can be taken to extremes, where every process is scheduled independently of every other. This is how Unix works. But even in these environments single loop multitasking is implemented within the process. They are called threads. For preemptive multitasking to work you need to be able to suspend the low priority stuff and restart it from where you left off. When you store the low priority task you have to store the entire machine state. This involves a lot more work than switching tasks within a loop. COLDFORTH running on the COLDFIRE has to save 16 general purpose registers and 3 MAC registers. On a processor running Unix properly, there is a memory protection system that limits the memory a process can access. Unix task switch code has to deal with the memory protection system; saving what is, and setting things up for what will be. The COLDFORTH scheduler There are many different ways to schedule tasks in a preemptive environment. COLDFORTH has a limited number of tasks loops and the loops are scheduled in a well defined manner. When you initiate a reschedule in an interrupt routine you set the active flag true for the level you want scheduled, and you make sure the priority level to be scheduled next ( _xlevel_next) is at least as high as the priority of the level you want scheduled. When the OS switches from supervisor state to user state it looks at the priority of the level currently being run ( _xlevel), if it is lower than _xlevel_next the OS suspends the current level and activates the higher level. INCLUDEPICTURE \d "./tasking.png" When the interrupt occurs the multitasker was running clock_medium. The active flag is still set for clock_ip. Clock_low has the repeat flag set, as is always the case for the lowest priority level. The digital1 interrupt sets the active flag for the digital1 task loop, and raises the priority to that level. When the system switches back from supervisor state to user state it suspends clock_medium and starts the digital1 task. When the digital1 task loop is started the active flag for the level is reset. When the digital1 tasks are finished, we look to see if the digital2 level was suspended; it wasn't; so it looks at the active flag. The active flag is not set so nothing in the digital2 level is executed. The clock_high level has nothing to do. That level is ignored also. The clock_medium level was the level interrupted, so the machine state is restored and execution continues in the clock_medium level. When clock_medium is finished the OS looks at clock_ip, that level has no machine state stored but has its active flag set so the active flag is reset and the tasks on the clock_ip level are looked at. After clock_ip, clock_low is looked at. Clock low has a machine state stored ( this will always be the case). The level is inititated from the saved state. When the level is finished HYPERLINK "./traps.html" \l "trap27"trap27 is executed. The next level is once again clock_low. Clock_low has it's repeat flag set so the tasks in the level are then looked at again. The COLDFIRE multitasking words The COLDFIRE task supports task activation modes that reflect real time control requirements. To highlight their significance they all start with x. PRIVATEmultitasking wordsWORDSTACKDESCRIPTIONxcycle( n--)Add n to the task activation time and wait until thenxnext( --)Exit to the multitasker without altering the tasks statusxoff( --)Set the tasks status to sleep and exit to the multitaskerxpause( --)Set the tasks status to wake and exit to the multitaskerxsleep( --)Set the tasks status to sleepxtest( --)Set the tasks status to testXtimeout?( --flag)Did an external event wake us or did we time outxwait( n--)Wait n ticks ( where a tick is 10 msec) and start the task againxwake( --)Set the tasks status to wakeThe difference between xcycle and xwait may need some explanation. xwait takes the current time and adds n and uses that as the next task activation time. If the task slips because of overload, the time is lost forever. xcycle takes the time when the task should of been activated and adds n to it. If the task slips the lost time is made up next time around. If you program anns_ramp_function as follows ram_variable %ramp_value #clock_medium task: ramp BEGIN #ramp_rate %ram_value +! %ram_value @ to_analog_output 10 xcycle AGAIN ;task The following output can then occur if the program is run on a heavily loaded system. INCLUDEPICTURE \d "./ramp4.png" There is a potential problem. If the system is continually overloaded there will never be an opportunity to catch up. The COLDFIRE task loop It is common in FORTH systems for a task to start with an instruction that controls behavior, with the instruction being altered as the tasks status changes. For example, if the task is suspended the instruction could be one that jumped to the instruction at the start of the next task. If the task is to be awakened the instruction could be a call to a routine that starts the task. Unfortunately for this scheme to work you must be able to write self modify code. Many processors now support separate instruction and data caches, such processes place one major restriction on the program. You cannot modify the instruction stream without flushing the cache. The 5407 will be such a processor. COLDFORH tasks start with an instruction ( HYPERLINK "./traps.html" \l "trap22"trap22 for the COLDFIRE) but it is fixed. The state of the task is determined by a numeric value stored after the trap instruction. The value in fact, could be used as an offset into a jump table. The following diagram shows what a task loop would look like if it contained two tasks, one that could be activated through dual port memory, and one that is internal to the system. INCLUDEPICTURE \d "./task_loop.png" The things to note are: The level switching is handled by HYPERLINK "./traps.html" \l "trap27"trap27 Task activation is handled by HYPERLINK "./traps.html" \l "trap22"trap22 The ability to put the activation area in dual port memory complicates the structure as the activation area is not always at the start of the tasks user area _system_rte trap27 These two words hold the multitasker together. If you understand how these work, you understand the system. Unfortunately they are, and have to be code words. When discussing the suspension of low level task we talked about interrupts setting active flags and raising the priority level, then when switching from supervisor to use mode, running the higher level. When returning from an exception you have to return with HYPERLINK "./system_rte.html" \l "_system_rte"_system_rte. This code looks to see if you are switching back to user, and if you are, looks to see if the current loop needs to be suspended and a high loop started. When an exception is executed COLDFORTH switches to a supervisor stack. When task loops are suspended all exceptions have been serviced. We are about to switch back to user state. We could save the machine state on the supervisor stack and allow it to sit there until we next want to schedule that level. That is what we do. We leave the user stack and the supervisor stack with the exception frame that started the process, and we stack onto the supervisor stack the machine state. We then set up an exception frame that will take us to the level that we want to start and we return from the exception. HYPERLINK "./traps.html" \l "trap27"trap27, the code that is responsible for level switching, removes the exception frame that was created when it was called, looks at the supervisor stack to see if there is a relevant machine state stored. If there is, HYPERLINK "./traps.html" \l "trap27"trap27 restores the machine state and returns from the exception using the exception frame that was created in times gone by. If there is no relevant machine state stored on the supervisor for the level about to be started, HYPERLINK "./traps.html" \l "trap27"trap27 sets up a frame to start the first action in the next level. _system_rte The code for HYPERLINK "./system_rte.html" \l "_system_rte"_system_rte runs something like this: : system_rte ( excpt_frame -- excpt_frame machine_state _xlevel@| ) are_we_returning_to_user \ stuff flag <-- _xlevel_next @ _xlevel @ > \ stuff flag flag <-- AND IF save_the_machine_state _xlevel @ \ excpt_frm mach_st _xl <-- _xlevel_next @ setup_an_excpt_frame \ excpt_frm mach_st _xl excpt_frm2 <-- THEN return_from_exception ; Things are a little complex as you have to take care to preserve all registers up to the time you save the machine state, or if you don't save the machine state, you have to preserve the machine state until you return_from_exception. For this reason HYPERLINK "./system_rte.html" \l "_system_rte"_system_rte is written in machine code. trap27 The code for HYPERLINK "./traps.html" \l "trap27"trap27 runs something like this: : trap27 ( ?? old_xlevel@ excpt_frame -- ?? old_xlevel@ excpt_frame) remove_exception_frame \ ?? old_xlevel@ <-- DUP level_we_want_to_switch_to = IF \ expt_frm mach_st old_xlevel <-- setup_machine_state \ exception_frame<-- ELSE setup_expt_frame_to_start_new_level THEN return_from_exception ; Once again things are a little complex, we may get ourselves into the situation where we are trying to restore a machine state. For this reason HYPERLINK "./traps.html" \l "trap27"trap27 is written in code. PRIVATEINCLUDEPICTURE \d "./system_stack.png"There can be multiple machine states saved on the system stack. But the high priority levels will be saved on top of the low priority levels. This diagram shows a possible system stack state when servicing a high priority interrupt.  trap22 After HYPERLINK "./system_rte.html" \l "_system_rte"_system_rte and HYPERLINK "./traps.html" \l "trap27"trap27, HYPERLINK "./traps.html" \l "trap22"trap22 is positively boring. You don't even have to run it with interrupts disabled. We do however have to destroy the exception frame so it to is written in code. The code for HYPERLINK "./traps.html" \l "trap22"trap22 runs something like this: : trap22 ( exception_frame -- ) set_us_beack_to_user_mode remove_exception_frame_leave_status_address \ status_address<-- DUP @ sleep = IF DROP jump_to_next_in_loop THEN DUP wake = IF DROP activate_task THEN DUP test = IF task_restart_time @ xclock- @ + 0< IF DROP activate_task THEN THEN next_in_loop ; How we test for activation time is the only noteworthy item. The interrupt clock increments a counter called xclock+ and decrements a counter called xclock-. Then you want to set an activation time you take the xclock+ value add the delay and store as the task activation time. To see if the time has expired you add the stored value to the contents of xclock-. Programming model To write code in a multitasking environment you lose total control. You have to follow some rules. In a single loop multitasker you can assume you have resources that are shared with other processors up until you exit to the multitasker. This assumption is the foundation of systems that implement FORTH BLOCKs as a consistent shared resource. That is all tasks will see the same data, and tasks can alter data in a BUFFER/BLOCK, but must execute UPDATE before exiting to the multitasker. With preemptive multitasking such assumptions are not valid. The only data tasks can alter is data they own. If you use blocks, only one task can have access to the block at a time. BUFFER or BLOCK must make a copy of the data available to the task, UPDATE must write the data back to the file system. But what happens if two task ask for the same buffer. There are now two copies and two potential updates. The only solution is to lock the block until the UPDATE occurs Not the correct action if the task only wanted to read the block. The solution in such an environment is to move to a OPEN-READ/WRITE-CLOSE paradigm. You can then indicate the desired operation ( read or write ) when opening the file. If you're going to add the overhead of opening/closing the resource you may as well go for something larger than a block. The FORTH file words suddenly become very important. The block words next to useless. The strict priority used to schedule the COLDFORTH task loops however allows one useful generalization. If you're in a high priority task altering data that is used by a low priority task, you will get to finish your job before the low priority task gets to play. This generalization is used a lot in the COLDFORTH TCP/IP implementation. ^ _ ~      s t %&FGHIW+)*+,-L#M#q#r#s#y#z#$$$$CJ jCJ U0JCJjCJU jCJUCJjCJ UmHnH6CJ 0J#CJ j%CJ UmHnHjmCJ UmHnHjCJ UmHnHjCJ UmHnH jCJ U5CJ CJ 6[\ F D ^  s %JVXm v%[\ F D ^  s %JVXm)+. '>GNTUVjP:\E]\Qj"-$)$$$$$$$$$$$%;%<%B%   ])+. '>GNTUVj v%P:\E]\Qj"-$)$$$$$$$$ & F$$$$$$$$$$$$$<%A%%%%%&&<&A&f&o&&&&'<'B'G'L'h'm'(((((L)))))))=->-b-c-d-j-k-../ / / /G/H/l/˱˦j CJ UmHnH0JCJ j< CJ Uj CJ UmHnH jCJ U0J#CJ 6CJ 0JCJ CJ 5CJ 0J$CJ jCJ UjbCJ U>$$$$$$$%;%<%B%H%%%%%%%%%`)$$F$$)$$F$B%H%%%%%%%%%&&&&;&<&B&H&e&f&p&z&&&&&&&''$'%'(((((()3)?)F)L)N)))A*Y*+-+.. /%/w//d0x0112*4V5677A8C8888888919W999999::U;W;;;;;<)<@<F<l<r<   _%&&&&;&<&B&H&e&f&p&z&&&&&&&''$'%'((ӰӨ<Ө)$$F$$((((()3)?)F)L)N)))A*Y*+-+.. /%/w//d0x0112*4 & F v%l/m/n/t/u////////d0x022M2N2O2Z2[2V5W5{5|5}555X6Y6}6~6666a7b7777777777888$8%8B89::::::: ; ;jbCJ U0J#CJ jCJ UjCJ UjCJ Uj1CJ UjUCJ Uj CJ UCJ 0JCJ jCJ Uj CJ U=*4V5677A8C8888888919W999999::U;W;;;;; v% ;0;1;2;8;9;V;<==B=C=D=J=K=c=d=k=l=m=n=====>>>>>>>>>>>>????*?+?,?2?3???@@@ @ @*@wAAjCJ Uj6CJ UjoCJ UjCJ UjCJ UmHnHjCJ UCJ jCJ UjCJ U0J#CJ 0JCJ jCJ Uj>CJ UCJ 7;<)<@<F<l<r<<<<`=c==>>>>?)@+@K@f@@@@$$0$$ v%r<<<<`=c==>>>>?)@+@K@f@@@@@@@@@A AAAAIAZAaAgAuAwAyABBDGvHII  )@@@@@@A AAAAIAZAaAgAuAwAyABBDGvHII v%AABBLBSBBBBBH~II5CJ CJ 6CJ +0P/ =!"#$%Df 2  ./ramp.png^  c :? ./ramp.pngDf  ./ramp1.png`  c <? ./ramp1.pngDf  ./ramp2.png`  c <? ./ramp2.pngDf$ ./ramp3.png`  c <? ./ramp3.pngDf;. ./tasking.pngd  c @? ./tasking.pngDyK  F TRAPS~1.HTMtraps.htmltrap27"D  $w;;;...X<@<'u=   *=  *y>*>}??$ "0 a" Df ./ramp4.png`  c <? ./ramp4.pngDyK  F TRAPS~1.HTMtraps.htmltrap22Df&.ll./task_loop.pngh  c D ? ./task_loop.pngDyK  F TRAPS~1.HTMtraps.htmltrap27DyK  F TRAPS~1.HTMtraps.htmltrap22DyK  F SYSTEM~1.HTM$system_rte.html _system_rteDyK  F TRAPS~1.HTMtraps.htmltrap27DyK  F TRAPS~1.HTMtraps.htmltrap27DyK  F TRAPS~1.HTMtraps.htmltrap27DyK  F SYSTEM~1.HTM$system_rte.html _system_rteDyK  F SYSTEM~1.HTM$system_rte.html _system_rteDyK  F TRAPS~1.HTMtraps.htmltrap27DyK  F TRAPS~1.HTMtraps.htmltrap27D$ " " "!"Df$./system_stack.pngn  c J&? ./system_stack.pngDyK  F SYSTEM~1.HTM$system_rte.html _system_rteDyK  F TRAPS~1.HTMtraps.htmltrap27DyK  F TRAPS~1.HTMtraps.htmltrap22DyK  F TRAPS~1.HTMtraps.htmltrap22) [<@<Normal 1$ddCJhmH nH <A@<Default Paragraph Font::Definition Term >>Definition Listh(O( Definition6**H1$@& 5CJ0KH$&O&H2$@&5CJ$&O&H3$@&5CJ"O"H4$@&5&&H5$@&5CJ&&H6$@&5CJ..Address 600 Blockquote hhOCITE6$O$CODE CJOJQJ$X@$Emphasis6(U@( Hyperlink>*B*8V@8FollowedHyperlink>*B* 0O0Keyboard5CJOJQJfOf Preformatted0  # ~= z9!v% CJOJQJZZz-Bottom of Form!$1$$d<CJOJQJhmH nH TT z-Top of Form"$1$&d<CJOJQJhmH nH $O1$SampleOJQJ W@A Strong50OQ0 Typewriter CJOJQJ$Oa$Variable6,Oq, HTML Markup<B*"O"Comment<E$l/ ;AI16;=A$%(*4;@I24579:<>@B%r<I38?^~s % F H )+Lry%%%=)c)j)*+ +G+m+t++++.N.Z.V1|11X2~22a33334$4666 717879C9J9m999:::::;;+;2;;< <ECCCCCXCXCXXXXXXXXXXCXXXXZ l n   (   ) = @ F X c k ~ co EQu} %f,p,P.Z.334$4E4O4R4]4a4l4m4z4|444444444445 555 5!5(5*5,545?5B5V5[5d5e5l5n5p555t6666e7p7q7|777777777777778888(8-8<8H8k8s88::6<E<L<e<g<<<<<<<==,=/=5=L=Y=h=t===>>L>S>>>(@.@Echarlese2C:\BCM550\multitaskingpaper\multitasking_paper.doccharlese3C:\TEMP\AutoRecovery save of multitasking_paper.asd*`.@h OJQJo(@EEpEEE`@GTimes New Roman5Symbol3& Arial?5 Courier New"Ah;f;f @7X 8c$PDCVS FORTH KERNELforth Charles EssoncharleseOh+'0t  0 < HT\dlCVS FORTH KERNELdVS Charles EssonELforths  Normal.doto charleseto2arMicrosoft Word 8.0@@U0@U0 @7՜.+,D՜.+,` px  Colour Vision Systems RXPj CVS FORTH KERNEL TitleP 0nv  _PID_GUID _PID_HLINKS descriptionAN{59D182E0-8983-11D3-B769-0060083135F2}A@DE traps.htmltrap22DB traps.htmltrap22D? traps.htmltrap27Y<<system_rte.html _system_rteD6 traps.htmltrap27D3 traps.htmltrap27Y<0system_rte.html _system_rteY<-system_rte.html _system_rteD* traps.htmltrap27D' traps.htmltrap27D$ traps.htmltrap27Y<!system_rte.html _system_rteD traps.htmltrap22D traps.htmltrap27D traps.htmltrap22D traps.htmltrap27q)  ./ramp.pngp~  ./ramp1.pngs~  ./ramp2.pngr~G ./ramp3.pngW *./tasking.pngu~) ./ramp4.pngf /./task_loop.pngC!=./system_stack.png0 COLDFORTH uses this file to generate COLDFORTH  !"#$%&'()*+,-./0123456789:;<=>?@ABDEFGHIJKLMNOQRSTUVWXY[\]^_`acdefghilRoot EntryEF(! F 5Bыo0nData C1TablePWordDocument-SummaryInformation(ZDocumentSummaryInformation8/N bCompObjL  s^" jObjectPool Lo0o0t  FMicrosoft Word Document MSWordDocWord.Document.89q./version081/multitaskingpaper/multitasking_paper.html0100777000000000000000000005073707300314367022211 0ustar rootroot CVS FORTH KERNEL

COLDFORTH Multitasking

If a computer is controlling a machine, TCP/IP should have a low priority. Stopping the machine at limit switches, generating a nice function output; they are all things of greater importance. What does it matter if a couple of datagrams get dropped, the network has probable dropped some anyway. The whole TCP/IP protocol suite is designed around the assumption that datagram delivery is unreliable.

COLDFORTH supports preemptive multitasking and places TCP/IP communication priority a level above the lowest level. The lowest level is used for user input. Both levels are below the priority levels used to control the machinery.

TCP/IP requires the timeout of routes, the timeout of ARP entries, timeout of defragmentation attempts, and the detection of TCP inaction. All these functions are placed in tasks that sit on the lowest priority level along with terminal input and buffer defragmentation. Getting the data through has a higher priority.

Having a preemptive multitasker allows you to give the plant priority and still enjoy the benefits TCP/IP brings to industrial control.

This article looks at why preemptive multitasking is important and how it is implemented in COLDFORTH.

Why is time important?

If you're using your computer to stop a piece of machinery at a limit switch or to generate time based waveforms; time matters. If you don't stop at the limit switch you run into the end stops. If you make a mess of an analog function generating a speed reference the equipment will not accelerate smoothly placing extra stress on the equipment and occupants.

Let's take a closer look at waveform generation. In the real world you create an S curve when generating a speed reference, such a curve limits the jerk ( the derivative of acceleration). For our example we will look at the generation of a simple ramp.

The desired function is.

If you implement your software well and take a close look at the output you will see what is shown below.

If you schedule badly but take into account the elapsed time, things look good at a distance. The magnified image is an irregular staircase. If this was controlling a DC machine the big steps would represent large current demands, current demands that could lead to equipment failure, or in extreme cases current demands the real world can't deliver.

And if you schedule badly, and don't take into account the elapsed time things don't look good even at a distance. As the diagram below shows.

To get the smooth option do I need preemptive multitasking?

The sort answer is no. You can do it with no multitasking. If an application programmer was trying to do the job with an OS that supported no multitasking they would simply call the ramp function regularly. 

 
: anns_ramp_function
	whatever_is_required
;


: my_function ( --)
	do_some_of_my_stuff
	anns_ramp_function
	do_some_more_of_my_stuff
	\ forget ann I need to get this job done
	\ anns_ramp_function
	and_so_on
;

If you do it this way all code has to contain calls to unrelated code. Not a very modular solution, and the reason why many FORTH systems support a single loop multitasker. The sample code them becomes. 

 
#clock_low task: anns_ramp_function
	BEGIN
		whatever_is_required
		xpause
	AGAIN
;task


: my_function ( --)
	do_some_of_my_stuff
	xpause
	do_some_more_of_my_stuff
	\ forget every one else I need to get this job done
	\ xpause
	and_so_on
;

In the FORTH environment switching from one task to the next in a task loop is a simple matter. You push the state of the FORTH environment onto a stack, save the stack pointer into a task specific location and start the next task. COLDFORTH is a subroutine threaded forth that supports local variables and objects. To switch tasks within a loop:

  • Pushes the current local variable pointer onto the data stack
  • Pushes the current object pointer onto the data stack
  • Pushes the return stack pointer onto the data stack
  • Store the current data stack pointer into the tasks user area
  • Active the next task in the loop

There are FORTHS that support single loop multitaskers, but don't maintain the local variable and object pointer in registers. These FORTH will switch tasks even faster.

The single loop multitasker brings one big advantage. You do not have to know anything about the other functions, you simply exit to the multitasker often, and give others a go.

There a two major problems:

  • All tasks have to be nice
  • If the system is overloaded the OS has no idea what is important and what is not.

A preemptive scheduler

A preemptive scheduler is run by an interrupt source. The interrupt can be anything; a clock, or if your computer is dealing with video images the horizontal sync. Whatever the event, the idea is simple. When the event occurs you suspend the low priority stuff ( which hopefully is where you are at) and start the high priority stuff. It then doesn't matter how the low priority stuff behaves.

Preemptive multitasking can be taken to extremes, where every process is scheduled independently of every other. This is how Unix works. But even in these environments single loop multitasking is implemented within the process. They are called threads.

For preemptive multitasking to work you need to be able to suspend the low priority stuff and restart it from where you left off. When you store the low priority task you have to store the entire machine state. This involves a lot more work than switching tasks within a loop. COLDFORTH running on the COLDFIRE has to save 16 general purpose registers and 3 MAC registers.

On a processor running Unix properly, there is a memory protection system that limits the memory a process can access. Unix task switch code has to deal with the memory protection system; saving what is, and setting things up for what will be.

The COLDFORTH scheduler

There are many different ways to schedule tasks in a preemptive environment. COLDFORTH has a limited number of tasks loops and the loops are scheduled in a well defined manner.

When you initiate a reschedule in an interrupt routine you set the active flag true for the level you want scheduled, and you make sure the priority level to be scheduled next ( _xlevel_next) is at least as high as the priority of the level you want scheduled.

When the OS switches from supervisor state to user state it looks at the priority of the level currently being run ( _xlevel), if it is lower than _xlevel_next the OS suspends the current level and activates the higher level.

The diagram below shows what happens when a digital interrupt routine calls for a reschedule.

Description of above diagram follows

When the interrupt occurs the multitasker was running clock_medium. The active flag is still set for clock_ip. Clock_low has the repeat flag set, as is always the case for the lowest priority level.

The digital1 interrupt sets the active flag for the digital1 task loop, and raises the priority to that level. When the system switches back from supervisor state to user state it suspends clock_medium and starts the digital1 task. When the digital1 task loop is started the active flag for the level is reset.

When the digital1 tasks are finished, the level switching code looks to see if the digital2 level was suspended it wasn't so it looks at the active flag. It is not set so nothing in the digital2 level is executed. The clock_high level also was no machine state stored, and no active flag set. That level is ignored also. The clock_medium level was the level interrupted, so the machine state is restored and execution continues in the clock_medium level.

When clock_medium is finished the OS looks at clock_ip, that level has no machine state stored but has its active flag set so the active flag is reset and the tasks on the clock_ip level are looked at.

After clock_ip, clock_low is looked at. Clock low has a machine state stored ( this will always be the case). The level is inititated from the saved state. When the level is finished trap27 is executed. The next level is once again clock_low. Clock_low has it's repeat flag set so the tasks in the level are then looked at again.

The COLDFIRE multitasking words

The COLDFIRE task supports task activation modes that reflect real time control requirements. To highlight their significance they all start with x.

multitasking words
WORDSTACKDESCRIPTION
xcycle( n--)Add n to the task activation time and wait until then
xnext( --)Exit to the multitasker without altering the tasks status
xoff( --)Set the tasks status to sleep and exit to the multitasker
xpause( --)Set the tasks status to wake and exit to the multitasker
xsleep( --)Set the tasks status to sleep
xtest( --)Set the tasks status to test
xtimeout?( --flag)Did an external event wake us or did we time out
xwait( n--)Wait n ticks ( where a tick is 10 msec) and start the task again
xwake( --)Set the tasks status to wake

The difference between xcycle and xwait may need some explanation. xwait takes the current time and adds n and uses that as the next task activation time. If the task slips because of overload, the time is lost forever. xcycle takes the time when the task should of been activated and adds n to it. If the task slips the lost time is made up next time around. It you program anns_ramp_function as follows 

 
ram_variable %ramp_value
#clock_medium task: ramp
	BEGIN
		#ramp_rate %ram_value +!
		%ram_value @ to_analog_output
		10 xcycle
	AGAIN
;task

The following output can then occur if the program is run on a heavily loaded system.

There is a potential problem. If the system is continually overloaded there will never be an opportunity to catch up.

The COLDFIRE task loop

It is common in FORTH systems for a task to start with an instruction that controls behavior, with the instruction being altered as the tasks status changes. For example, if the task is suspended the instruction could be one that jumped to the instruction at the start of the next task. If the task is to be awakened the instruction could be a call to a routine that starts the task.

Unfortunately for this scheme to work you must be able to write self modify code. Many processors now support separate instruction and data caches, such processes place one major restriction on the program. You cannot modify the instruction stream without flushing the cache. The 5407 will be such a processor.

COLDFORH tasks start with an instruction ( trap22 for the COLDFIRE ) but it is fixed. The state of the task is determined by a numeric value stored after the trap instruction. The value in fact, could be used as an offset into a jump table.

The following diagram shows what a task loop would look like if it contained two tasks, one that could be activated through dual port memory, and one that is internal to the system.

The things to note are:

  • The level switching is handled by trap27
  • Task activation is handled by trap22
  • The ability to put the activation area in dual port memory complicates the structure as the activation area is not always at the start of the tasks user area

Dual port memory activation

Imagine if you had I/O cards that allowed you to write data to a buffer on the card, and then write an activation code to a memory location, and that code wakes up a task that was designed to deal with your problem. If you could do that you would no longer have to write polling or interrupt routines in the I/O card.

Supporting task activation through dual port memory gives you that.

_system_rte trap27

These two words hold the multitasker together. If you understand how these work, you understand the system. Unfortunately they are, and have to be code words.

When discussing the suspension of low level task we talked about interrupts setting active flags and raising the priority level, then when switching from supervisor to use mode, running the higher level.

When returning from an exception you have to return with _system_rte. This code looks to see if you are switching back to user, and if you are, looks to see if the current loop needs to be suspended and a high loop started.

When an exception is executed COLDFORTH switches to a supervisor stack. When task loops are suspended all exceptions have been serviced. We are about to switch back to user state. We could save the machine state on the supervisor stack and allow it to sit there until we next want to schedule that level.

That is what we do. We leave the user stack and the supervisor stack with the exception frame that started the process, and we stack onto the supervisor stack the machine state. We then set up an exception frame that will take us to the level that we want to start and we return from the exception.

trap27, the code that is responsible for level switching, removes the exception frame that was created when it was called, looks at the supervisor stack to see if there is a relevant machine state stored. If there is, trap27 restores the machine state and returns from the exception using the exception frame that was created in times gone by.

If there is no relevant machine state stored on the supervisor for the level about to be started, trap27 sets up a frame to start the first action in the next level.

_system_rte

The code for _system_rte runs something like this: 

 
: system_rte ( excpt_frame -- excpt_frame machine_state _xlevel@| )
	are_we_returning_to_user
	\ stuff flag <-- 
	_xlevel_next @ _xlevel @ > 
	\ stuff flag flag <--
	AND IF
		save_the_machine_state _xlevel @
		\ excpt_frame machine_state _xlevel@ <--
		_xlevel_next @ setup_an_excpt_frame
		\ excpt_frame machine_state _xlevel@ excpt_frame2 <--
	THEN
	return_from_exception
;

Things are a little complex as you have to take care to preserve all registers up to the time you save the machine state, or if you don't save the machine state, you have to preserve the machine state until you return_from_exception. For this reason _system_rte is written in machine code.

trap27

The code for trap27 runs something like this: 

 
: trap27 ( ?? old_xlevel@ excpt_frame -- ?? old_xlevel@ excpt_frame)
	remove_exception_frame
	\ ?? old_xlevel@ <--
	DUP level_we_want_to_switch_to = IF
		\ exception_frame machine_state old_xlevel@ <--
		setup_machine_state
		\ exception_frame<--
	ELSE
		setup_exception_frame_to_start_new_level
	THEN
	return_from_exception
;

Once again things are a little complex, we may get ourselves into the situation where we are trying to restore a machine state. For this reason trap27 is written in code.

There can be multiple machine states saved on the system stack. But the high priority levels will be saved on top of the low priority levels. This diagram shows a possible system stack state when servicing a high priority interrupt.

trap22

After _system_rte and trap27, trap22 is positively boring. You don't even have to run it with interrupts disabled. We do however have to destroy the exception frame so it to is written in code.

The code for trap22 runs something like this: 

 
: trap22 ( exception_frame -- )
	set_us_beack_to_user_mode
	remove_exception_frame_leave_status_address
	\ status_address<--
	DUP @ sleep = IF
		DROP
		jump_to_next_in_loop
	THEN
	DUP wake = IF
		DROP
		activate_task
	THEN
	DUP test = IF
		task_restart_time @ xclock- @ + 0< IF
			DROP
			activate_task
		THEN
	THEN
	next_in_loop
;

How we test for activation time is the only noteworthy item. The interrupt clock increments a counter called xclock+ and decrements a counter called xclock-. Then you want to set an activation time you take the xclock+ value add the delay and store as the task activation time. To see if the time has expired you add the stored value to the contents of xclock-. When the required time has passed the summation will be negative.

Programming model

To write code in a multitasking environment you lose total control. You have to follow some rules. In a single loop multitasker you can assume you have resources that are shared with other processors up until you exit to the multitasker. This assumption is the foundation of systems that implement FORTH BLOCKs as a consistent shared resource. That is all tasks will see the same data, and tasks can alter data in a BUFFER/BLOCK, but must execute UPDATE before exiting to the multitasker.

With preemptive multitasking such assumptions are not valid. The only data tasks can alter is data they own. If you use blocks, only one task can have access to the block at a time. BUFFER or BLOCK must make a copy of the data available to the task, UPDATE must write the data back to the file system. But what happens if two task ask for the same buffer. There are now two copies and two potential updates. The only solution is to lock the block until the UPDATE occurs Not the correct action if the task only wanted to read the block. The solution in such an environment is to move to a OPEN-READ/WRITE-CLOSE paradigm. You can then indicate the desired operation ( read or write ) when opening the file.

If you're going to add the overhead of opening/closing the resource you may as well go for something larger than a block. The FORTH file words suddenly become very important. The block words next to useless.

The strict priority used to schedule the COLDFORTH task loops however allows one useful generalization. If you're in a high priority task altering data that is used by a low priority task, you will get to finish your job before the low priority task gets to play.

This generalization is used a lot in the COLDFORTH TCP/IP implementation.

./version081/multitaskingpaper/multitasking_paper_slides.html0100777000000000000000000005274407300314367023554 0ustar rootroot multitasking_paper_slides

COLDFORTH Multitasking

Colour Vision Systems build systems that sort fruit using video cameras. It is nice to see what the system is seeing. And when you want to, see it quickly. Our networks face a chunky high bandwidth load.

If a computer is controlling a machine, TCP/IP should have a low priority. Stopping the machine at limit switches, generating a nice function output; they are all things of greater importance. What does it matter if a couple of datagrams get dropped, the network has probable dropped some anyway. The whole TCP/IP protocol suite is designed around the assumption that datagram delivery is unreliable.

COLDFORTH supports preemptive multitasking and places TCP/IP communication priority one level above the lowest level. The lowest level is used for user input. Both levels are below the priority levels used to control the machinery.

TCP/IP requires the timeout of routes, the timeout of ARP entries, timeout of defragmentation attempts, and the detection of TCP inaction. All these functions are placed in tasks that sit on the lowest priority level along with terminal input and buffer defragmentation. Getting the data through has a higher priority.

Having a preemptive multitasker allows you to give the plant priority and still enjoy the benefits TCP/IP brings to industrial control.

This article looks at why preemptive multitasking is important and how it is implemented in COLDFORTH.

Why is time important?

If you're using your computer to stop a piece of machinery at a limit switch or to generate time based waveforms; time matters. If you don't stop at the limit switch you run into the end stops. If you make a mess of an analog function generating a speed reference the equipment will not accelerate smoothly placing extra stress on the equipment and occupants.

Let's take a closer look at waveform generation. In the real world you create an S curve when generating a speed reference, such a curve limits the jerk ( the derivative of acceleration). For our example we will look at the generation of a simple ramp.

The desired function is.

If you implement your software well and take a close look at the output you will see what is shown below.

If you schedule badly but take into account the elapsed time, things look good at a distance. The magnified image is an irregular staircase. If this was controlling a DC machine the big steps would represent large current demands, current demands that could lead to equipment failure, or in extreme cases current demands the real world can't deliver.

And if you schedule badly, and don't take into account the elapsed time things don't look good even at a distance. As the diagram below shows.

To get the smooth option do I need preemptive multitasking?

The sort answer is no. You can do it with no multitasking. If an application programmer was trying to do the job with an OS that supported no multitasking they would simply call the ramp function regularly. 

 
: anns_ramp_function
	whatever_is_required
;


: my_function ( --)
	do_some_of_my_stuff
	anns_ramp_function
	do_some_more_of_my_stuff
	\ forget ann I need to get this job done
	\ anns_ramp_function
	and_so_on
;

If you do it this way all code has to contain calls to unrelated code. Not a very modular solution, and the reason why many FORTH systems support a single loop multitasker. The sample code them becomes. 

 
#clock_low task: anns_ramp_function
	BEGIN
		whatever_is_required
		xpause
	AGAIN
;task


: my_function ( --)
	do_some_of_my_stuff
	xpause
	do_some_more_of_my_stuff
	\ forget every one else I need to get this job done
	\ xpause
	and_so_on
;

In the FORTH environment switching from one task to the next in a task loop is a simple matter. You push the state of the FORTH environment onto a stack, save the stack pointer into a task specific location and start the next task. COLDFORTH is a subroutine threaded forth that supports local variables and objects. To switch tasks within a loop:

  • Pushes the current local variable pointer onto the data stack
  • Pushes the current object pointer onto the data stack
  • Pushes the return stack pointer onto the data stack
  • Store the current data stack pointer into the tasks user area
  • Active the next task in the loop

There are FORTHS that support single loop multitaskers, but don't maintain the local variable and object pointer in registers. These FORTH will switch tasks even faster.

The single loop multitasker brings one big advantage. You do not have to know anything about the other functions, you simply exit to the multitasker often, and give others a go.

There a two major problems:

  • All tasks have to be nice
  • If the system is overloaded the OS has no idea what is important and what is not.

A preemptive scheduler

A preemptive scheduler is run by an interrupt source. The interrupt can be anything; a clock, or if your computer is dealing with video images the horizontal sync. Whatever the event, the idea is simple. When the event occurs you suspend the low priority stuff ( which hopefully is where you are at) and start the high priority stuff. It then doesn't matter how the low priority stuff behaves.

Preemptive multitasking can be taken to extremes, where every process is scheduled independently of every other. This is how Unix works. But even in these environments single loop multitasking is implemented within the process. They are called threads.

For preemptive multitasking to work you need to be able to suspend the low priority stuff and restart it from where you left off. When you store the low priority task you have to store the entire machine state. This involves a lot more work than switching tasks within a loop. COLDFORTH running on the COLDFIRE has to save 16 general purpose registers and 3 MAC registers.

On a processor running Unix properly, there is a memory protection system that limits the memory a process can access. Unix task switch code has to deal with the memory protection system; saving what is, and setting things up for what will be.

The COLDFORTH scheduler

There are many different ways to schedule tasks in a preemptive environment. COLDFORTH has a limited number of tasks loops and the loops are scheduled in a well defined manner.

When you initiate a reschedule in an interrupt routine you set the active flag true for the level you want scheduled, and you make sure the priority level to be scheduled next ( _xlevel_next) is at least as high as the priority of the level you want scheduled.

When the OS switches from supervisor state to user state it looks at the priority of the level currently being run ( _xlevel), if it is lower than _xlevel_next the OS suspends the current level and activates the higher level.

The diagram below shows what happens when a digital interrupt routine calls for a reschedule.

Description of above diagram follows

When the interrupt occurs the multitasker was running clock_medium. The active flag is still set for clock_ip. Clock_low has the repeat flag set, as is always the case for the lowest priority level.

The digital1 interrupt sets the active flag for the digital1 task loop, and raises the priority to that level. When the system switches back from supervisor state to user state it suspends clock_medium and starts the digital1 task. When the digital1 task loop is started the active flag for the level is reset.

When the digital1 tasks are finished, the level switching code looks to see if the digital2 level was suspended it wasn't so it looks at the active flag. It is not set so nothing in the digital2 level is executed. The clock_high level also was no machine state stored, and no active flag set. That level is ignored also. The clock_medium level was the level interrupted, so the machine state is restored and execution continues in the clock_medium level.

When clock_medium is finished the OS looks at clock_ip, that level has no machine state stored but has its active flag set so the active flag is reset and the tasks on the clock_ip level are looked at.

After clock_ip, clock_low is looked at. Clock low has a machine state stored ( this will always be the case). The level is inititated from the saved state. When the level is finished trap27 is executed. The next level is once again clock_low. Clock_low has it's repeat flag set so the tasks in the level are then looked at again.

The COLDFIRE multitasking words

The COLDFIRE task supports task activation modes that reflect real time control requirements. To highlight their significance they all start with x.

multitasking words

WORD

STACK

DESCRIPTION

xcycle

( n--)

Add n to the task activation time and wait until then

xnext

( --)

Exit to the multitasker without altering the tasks status

xoff

( --)

Set the tasks status to sleep and exit to the multitasker

xpause

( --)

Set the tasks status to wake and exit to the multitasker

xsleep

( --)

Set the tasks status to sleep

xtest

( --)

Set the tasks status to test

xtimeout?

( --flag)

Did an external event wake us or did we time out

xwait

( n--)

Wait n ticks ( where a tick is 10 msec) and start the task again

xwake

( --)

Set the tasks status to wake

The difference between xcycle and xwait may need some explanation. xwait takes the current time and adds n and uses that as the next task activation time. If the task slips because of overload, the time is lost forever. xcycle takes the time when the task should of been activated and adds n to it. If the task slips the lost time is made up next time around. It you program anns_ramp_function as follows 

 
ram_variable %ramp_value
#clock_medium task: ramp
	BEGIN
		#ramp_rate %ram_value +!
		%ram_value @ to_analog_output
		10 xcycle
	AGAIN
;task

The following output can then occur if the program is run on a heavily loaded system.

There is a potential problem. If the system is continually overloaded there will never be an opportunity to catch up.

The COLDFIRE task loop

It is common in FORTH systems for a task to start with an instruction that controls behavior, with the instruction being altered as the tasks status changes. For example, if the task is suspended the instruction could be one that jumped to the instruction at the start of the next task. If the task is to be awakened the instruction could be a call to a routine that starts the task.

Unfortunately for this scheme to work you must be able to write self modify code. Many processors now support separate instruction and data caches, such processes place one major restriction on the program. You cannot modify the instruction stream without flushing the cache. The 5407 will be such a processor.

COLDFORH tasks start with an instruction ( trap22 for the COLDFIRE ) but it is fixed. The state of the task is determined by a numeric value stored after the trap instruction. The value in fact, could be used as an offset into a jump table.

The following diagram shows what a task loop would look like if it contained two tasks, one that could be activated through dual port memory, and one that is internal to the system.

The things to note are:

  • The level switching is handled by trap27
  • Task activation is handled by trap22
  • The ability to put the activation area in dual port memory complicates the structure as the activation area is not always at the start of the tasks user area

Dual port memory activation

Imagine if you had I/O cards that allowed you to write data to a buffer on the card, and then write an activation code to a memory location, and that code wakes up a task that was designed to deal with your problem. If you could do that you would no longer have to write polling or interrupt routines in the I/O card.

Supporting task activation through dual port memory gives you that.

_system_rte trap27

These two words hold the multitasker together. If you understand how these work, you understand the system. Unfortunately they are, and have to be code words.

When discussing the suspension of low level task we talked about interrupts setting active flags and raising the priority level, then when switching from supervisor to use mode, running the higher level.

When returning from an exception you have to return with _system_rte. This code looks to see if you are switching back to user, and if you are, looks to see if the current loop needs to be suspended and a high loop started.

When an exception is executed COLDFORTH switches to a supervisor stack. When task loops are suspended all exceptions have been serviced. We are about to switch back to user state. We could save the machine state on the supervisor stack and allow it to sit there until we next want to schedule that level.

That is what we do. We leave the user stack and the supervisor stack with the exception frame that started the process, and we stack onto the supervisor stack the machine state. We then set up an exception frame that will take us to the level that we want to start and we return from the exception.

trap27, the code that is responsible for level switching, removes the exception frame that was created when it was called, looks at the supervisor stack to see if there is a relevant machine state stored. If there is, trap27 restores the machine state and returns from the exception using the exception frame that was created in times gone by.

If there is no relevant machine state stored on the supervisor for the level about to be started, trap27 sets up a frame to start the first action in the next level.

_system_rte

The code for _system_rte runs something like this: 

 
: system_rte ( excpt_frame -- excpt_frame machine_state _xlevel@| )
	are_we_returning_to_user
	\ stuff flag <-- 
	_xlevel_next @ _xlevel @ > 
	\ stuff flag flag <--
	AND IF
		save_the_machine_state _xlevel @
		\ excpt_frame machine_state _xlevel@ <--
		_xlevel_next @ setup_an_excpt_frame
		\ excpt_frame machine_state _xlevel@ excpt_frame2 <--
	THEN
	return_from_exception
;

Things are a little complex as you have to take care to preserve all registers up to the time you save the machine state, or if you don't save the machine state, you have to preserve the machine state until you return_from_exception. For this reason _system_rte is written in machine code.

trap27

The code for trap27 runs something like this: 

 
: trap27 ( ?? old_xlevel@ excpt_frame -- ?? old_xlevel@ excpt_frame)
	remove_exception_frame
	\ ?? old_xlevel@ <--
	DUP level_we_want_to_switch_to = IF
		\ exception_frame machine_state old_xlevel@ <--
		setup_machine_state
		\ exception_frame<--
	ELSE
		setup_exception_frame_to_start_new_level
	THEN
	return_from_exception
;

Once again things are a little complex, we may get ourselves into the situation where we are trying to restore a machine state. For this reason trap27 is written in code.

There can be multiple machine states saved on the system stack. But the high priority levels will be saved on top of the low priority levels. This diagram shows a possible system stack state when servicing a high priority interrupt.

trap22

After _system_rte and trap27, trap22 is positively boring. You don't even have to run it with interrupts disabled. We do however have to destroy the exception frame so it to is written in code.

The code for trap22 runs something like this: 

 
: trap22 ( exception_frame -- )
	set_us_beack_to_user_mode
	remove_exception_frame_leave_status_address
	\ status_address<--
	DUP @ sleep = IF
		DROP
		jump_to_next_in_loop
	THEN
	DUP wake = IF
		DROP
		activate_task
	THEN
	DUP test = IF
		task_restart_time @ xclock- @ + 0< IF
			DROP
			activate_task
		THEN
	THEN
	next_in_loop
;

How we test for activation time is the only noteworthy item. The interrupt clock increments a counter called xclock+ and decrements a counter called xclock-. Then you want to set an activation time you take the xclock+ value add the delay and store as the task activation time. To see if the time has expired you add the stored value to the contents of xclock-. When the required time has passed the summation will be negative.

Programming model

To write code in a multitasking environment you lose total control. You have to follow some rules. In a single loop multitasker you can assume you have resources that are shared with other processors up until you exit to the multitasker. This assumption is the foundation of systems that implement FORTH BLOCKs as a consistent shared resource. That is all tasks will see the same data, and tasks can alter data in a BUFFER/BLOCK, but must execute UPDATE before exiting to the multitasker.

With preemptive multitasking such assumptions are not valid. The only data tasks can alter is data they own. If you use blocks, only one task can have access to the block at a time. BUFFER or BLOCK must make a copy of the data available to the task, UPDATE must write the data back to the file system. But what happens if two task ask for the same buffer. There are now two copies and two potential updates. The only solution is to lock the block until the UPDATE occurs Not the correct action if the task only wanted to read the block. The solution in such an environment is to move to a OPEN-READ/WRITE-CLOSE paradigm. You can then indicate the desired operation ( read or write ) when opening the file.

If you're going to add the overhead of opening/closing the resource you may as well go for something larger than a block. The FORTH file words suddenly become very important. The block words next to useless.

The strict priority used to schedule the COLDFORTH task loops however allows one useful generalization. If you're in a high priority task altering data that is used by a low priority task, you will get to finish your job before the low priority task gets to play.

This generalization is used a lot in the COLDFORTH TCP/IP implementation.

./version081/multitaskingpaper/print_system_data.html0100777000000000000000000000615407300314367022032 0ustar rootroot COLDFORTH KERNEL license
.tsk ( --)

Task details. #### This needs a lot of work. 

 
    : .TSK ( task --)
    	@  ( address of task table)
    	DUP @ (  task_table_addr status_addr <-)
    	CR
    	DUP ." user_base: " .h
    	DUP [ (S) user_base - ]T LITERAL + @ (  task_table status stack <--)
    	DUP @ ( old I ) ." I: " .h
    	DUP 4 + @ ( return top) DUP ." R: " .h
    	(  task_table status stack ret <--)
    	( print return stack)
    	CR ." return_stack"
    	jump ( status) OVER - 4 / zero ?DO
    		CR DUP I 4* + DUP .h SPACE @ .h
    	LOOP DROP
    	(  jump task_table status stack <--)
    	CR ." system_stack"
    	8 + ( saved R and I )
 \   	jump _#task_table_s0 + 
    	(  jump task_table status stack+8 base )
    	OVER - 4 / zero ?DO
    		CR  DUP I 4* + DUP .h SPACE @ .h
    	LOOP DROP ( stack)
    	(  jump task_table status <--)
    	2DROP
		send
    ;
.buffers ( --)

Print out the current buffer structure, for what is all means see the file heap_control.html. 

 
	: .buffers ( --)
		CR
		BASE @ >R
		HEX
		."     Size      Free      Used" CR   
		_#sys_buffer_list_number CELLS zero DO
			 I _#buffer_sizes + @  8 .R
			 2 SPACES
			 I _sys_buffer_list_free + _number_in_list 8 .R
			 2 SPACES
			 I _sys_buffer_list_used + _number_in_list 8 .R
			 CR
		4 +LOOP
		R> BASE !
		send
	;
.buffers_used

Print out details of the buffers used. 

 
	: .buffers_used
	   CR
	   BASE @ >R
	   HEX
	   ."   Address       Size      Task      Word"  CR
	   _#sys_buffer_list_number CELLS zero DO
			I _sys_buffer_list_used + @
			BEGIN
				DUP
			WHILE
				DUP [ _#sys_buffer_user _#sys_buffer_used_link - ]T LITERAL +
				8 .R  2 SPACES
				DUP   [ _#sys_buffer_size_code _#sys_buffer_used_link - ]T LITERAL + @ I <> IF
					." Rubbish"
   					DROP zero
   				ELSE                                                                
   					2 SPACES
   					I _#buffer_sizes + @ 8 .R 2 SPACES
   					DUP   [ _#sys_buffer_task  _#sys_buffer_used_link - ]T LITERAL + @
   					8 .R  ( #### .task when written)
   					2 SPACES
   					DUP   [ _#sys_buffer_ip    _#sys_buffer_used_link - ]T LITERAL + @
   					8 .R  ( #### ?.head when written)
					@
				THEN
				CR
			REPEAT
			DROP
		4 +LOOP
		R> BASE !
		send
	;


    
    ( free memory print) HEX
    : .free ( --)
		CR ." Dictionary : " _'h_task_top @  HERE      - 9 .R
		CR ." Ram        : " _'ram_top    @  ram_here  - 9 .R
		CR ." Fast ram   : " _'fast_top   @  fast_here - 9 .R 
		CR
		send  
	;
./version081/multitaskingpaper/ramp.png0100777000000000000000000000127407300314367017056 0ustar rootrootPNG  IHDRO0PLTE{GIDATxN#1DѾK߀M6cwWU (dlۍG8W[[opxx3Î΋Sqf"3G?//XqA>O_a|X!.}9ަ%b]X#}3ڤ bw=!};֢-~Cߦ;dAߧl`_Oz:gm=^jyzS"cZz!LȽ:C*Yu{.:.PQUϥX/$LtuN<t8]љw% :f։t^ރ:NRY\:(Lt*.\&t:ѕ\ ]āu!ץ-XWa]Cu)9EPA]t1\HW!]Ft9瀮zgZPR-Vz7׊z/л\r:MOLoga]Tݱkү -o7? zGީ[W_F]MCsŒv׾ ˾io7R>f<=Α֫IENDB`./version081/multitaskingpaper/ramp1.png0100777000000000000000000000362107300314367017135 0ustar rootrootPNG  IHDR'0PLTE{IDATxi `v2;ՠL iG*jm' 簚jb>zj.vJ~*((J̾JJ>b$-Jk.7ɖY0U{/wfe(2d"4<- 6˽A U/KPB$X+PujFG)5tR}:jt.(h ­|Ti(͵#IJobE!Q uҶb& xJ(7ԝTh(Ph(y(lCߨjߜ0Ge5 ŸsrY(6uI(tC;U$NSA%tC;V/!m"صqʡ 6PyʣtAT87lCUGBT;(LFq3$QjTw3P܉֝/.Sa$W]0O9}Bѩ(wgO_E'4ЕPQko7GP/'_J2Se8jwnDQ(.5W>oNPwLzܝw)ߚZ?L?oԝDE҇ڿPؙgB E%boZ~oYa@FTP;ب(j~Ix^: v2jpƙa\տ7aQ**4[x AQ6&_DQgٱ(|ukQݻS;% #.n$Ӕ(՞a P$ ŒcБkdJvCu-,d3p %جCu61bU?/i-J~% qbPCeZ9(:%~6z?$ JKgFn5A)"(((U$(!jd{t( (hQM =tFn?5P87]ȣVNZ]]i1*gҴxoؚQQ Ũhg&xI|j|_R_ШO~B|e?4dn|R(]ov"=Qh'Sqk e@9Ql?9X%ϳɒe%\2(y~ oj<(vw7&NJPC=|g`G2îB:Ab^)oRLGN67e`ӧLG2}d;XOt)n;=M՜sLION~V?Sz%yis_CX/(L\ywG<i||{0> L,0s&3eV{ m'IJLliNĜt>h2//e7Rv&]  L [0R̞ 7ڰ s{*h% 7Qt`5 5켹*kpWDŽ˹Z&qeBfuɷRb t,r 9,*nBߕj狏^UnPEZ59] u_3{i Dk&m`(}r %DK@2_I?iJ` rN5vC,2}70y,39g.3rÐIV\Tu[gb Ջo0ШXL=̎o$lsjZwe),4Իyk'ՉcjB"LՀFugqi%45%%qV2XjR.{Z2{^CuIQR~IXX1}ු^^u]LrkE~AA~'![qv&@# VqIENDB`./version081/multitaskingpaper/ramp3.png0100777000000000000000000000356007300314367017141 0ustar rootrootPNG  IHDR.ϟ0PLTE{IDATx %7R-fT/AY GIm.8qr)8U%D+f364'ԇNdty8gOPϟå!^1 OCf?Ϫ8B˦3p:GNQ ëь.wQ+ !#8N.=8㘨 C1joi WthYvđ4 i1Up]V{K#b]pHpp8>ݠ0OI.k((ts P8 8bx[I7ljpAyΗ錄9p\ywQ8l^K]sX'UMqE@v8=qΚC t;ⴛJ¨ɛ8X^s?{rS[_vƩً~ ĉ q.NuU]Bg8&-pƷV8s,&"8)&&-y8%}C`bNW/YGd= t88 y^5}u"B<ߕq/j$ u1cNlkDeQq: 9 KRG".#/Ӫ8{`Y(rG]G0&B qU`XpHͣc՝U&叠P7Qvp2>MaЕ:Qv91rw!8ZOmxh7X,6N qws8B8=ܦ)%n s 65anhGj2`[ܦ~b[U5k #6vlˀc7z+Y7 Z q.>XNc.7r+:.% DE)W cmq7ڻq9^ٴb;Vg'w̐L}޺&OjZX5^ 5D+ 1-vL_q\. z /8A.SHi]MFWfT,8T*ZRj{ا_u?uql54c:XhF!sa*3fJ%3aLW#pQxnѬm 7ޛZ;Bm=:!!G BlCi7Alt 0L1>6BF,?ge ҅2IENDB`./version081/multitaskingpaper/ramp4.png0100777000000000000000000000365107300314367017143 0ustar rootrootPNG  IHDR0PLTE{4IDATx[v P@fc:ĺG<66`~sv&+*Kq*g^ZUϸik,EBIs+t&xIި{OFL碴&a(If*ڨΤ&Sn2$ : eJxʘl=$9jsPrk}Au}A%_ I ru@;+@U)(ŽV/(bdt(ް1y'Ya,[dQt!=>RXPL]{%6DQ:(>(1ʬ0cBqS&( lp0TnX_tEGц8ب˜(aɖ14aPبBohhT04*6ȨbM`T\{|ۏ BU 㢨BXW^ KQQ£4(/EQ՘(E&ruFLTs"]@7 jѡؾ( >;(CP$x7%oݐ7nV%$P P¯X(a-J| [ b(ʫyIsQK@(x|bPCwVMi<ևd4 Jg0TT#]i(QP1PSg:*Rў@:H~o#PAPP }=q(T7)CL?Zճs)[k4kˮNQ]]hG՗^YPQX)72Spc@/ɍ@E)?4o eHE& | 2WSnS(.׈d 8aMqxQfP>u^y. $@[I. 8JX g8ڟamiv(RMi+0v=Yhp# }QꬣǥH[(lJcx()3.)nzd6ҷEu #Q[_5|ws N㪡qg^((m9'ԭ+(*TD9_FWv}|r*GyKMe r(Hc#&΁q>g)ML[~X[LXhQQP3PP/rotQ~#Q$PUUFW<]2 gYjV=J$Кz"j &p=9naw p[q=TN6˔n#0rsϪju\M 8իj<{k&]f*C% 1V /n梔*޳Q H<JE/ EhPL+e\=,z{T@G:Zwb6wA}?|R NIENDB`./version081/multitaskingpaper/system_rte.html0100777000000000000000000001430107300314367020470 0ustar rootroot COLDFORTH KERNEL license

.S .( Into system_rte.com) The coldfire doesn't have hardware to support the supervisor stack pointer. This is done in software as tasks should not have to make allowances for interrupt code. As it is tasks will have 8 bytes put on there stacks by interrupt code.

Describe the user return stack

 
	zero 
	DUP  CONSTANT _#int_user_A0     4+
	DUP  CONSTANT _#int_user_format 2+
	DUP  CONSTANT _#int_user_status 2+
	DUP  CONSTANT _#int_user_return 4+
	DROP

Support word

 
	CODE _set_new_task_level ( level --)
		S )+ D1 MOV
		7 100 * 2000 + # SR W. MOV
		_xlevel_next AB D0 MOV
		D1 D0 CMP GT IF
			D1 _xlevel_next AB  MOV
		THEN
	NEXT

Variable to save the return stack value when we switch back to user state 

 
	ram_variable _%int_stack_pointer

Without hardware support for the user stack pointer interrupt entry is a little more complex

You have to swap to interrupt stack on interrupt, to do otherwise is to require very large task stacks.

_%int_stack_pointer and _%int_stack_in_use have to be indivisiable correct so when being altered interrupts have to be disabled. Also level seven cannot use the interrupts stack.

Level 7 cannot use the super stack

We leave thsi word with interrupts disabled, it is up to the rest of the code to set interrupts at the required level.

Other code counts on A0 containing the user stack pointer 

 
	: system_entry
		\ disable interrupts
		46FC W, 2700 W,                   \ 2700 # SR MOV
		\ need a register, saved value is part of the system_rte stack frame
		2F08 W,                           \ A0 R -) MOV
		\ current return stack value
		204F W,                           \ R A0 MOV
		\ If we move from user to super change stack
		082F W, 05 W, _#int_user_status W, \ 5 # _#int_user_status R) BTST 
		6606 W,                           \ EQ IF
		2E79 W, _%int_stack_pointer ,     \      _%int_stack_pointer AB R MOV
		                                  \ THEN
		2F08 W,                           \ A0 R -) MOV
	;

	forth : system_entry
		\ disable interrupts
		46FC tw, 2700 tw,                    \ 2700 # SR MOV
		\ need a register, saved value is part of the system_rte stack frame
		2F08 tw,                             \ A0 R -) MOV
		\ current return stack value
		204F tw,                             \ R A0 MOV
		\ If we move from user to super change stack
		082F tw, 05 tw, _#int_user_status tw, \ 5 # _#int_user_status R) BTST 
		6606 tw,                             \ EQ IF
		2E79 tw, HOST _%int_stack_pointer t,      \      _%int_stack_pointer AB R MOV
		                                     \ THEN
		2F08 tw,                             \ A0 R -) MOV
	forth
	;
	HOST

The interrupt code can raise the multitasker priority level. When you switch from interrupt to user state you have to check and if that has occured, raise the multitasker priority. 

     

	\ the _system_rte stack frame will remain on stack and get used when the level
	\ is restarted.
	CODE  _system_rte  assembler  
		( we have to test the SUP bit in the supervisor byte of the cpu_status word.)
		( We can use A0)
		( we must retain R value just in case we have to suspend)
		R )+ A0 MOV
		5 # _#int_user_status 0) B. BTST NE IF
			\ return to another supervisor state leave things alone)
			\ A0 AND R contain the same value
			R )+ A0 MOV
			RTE
		ELSE
			( We need another register )
			D0 R -) MOV

			( we need to stop interrupts, _xlevel_next and _xlevel)
			( next to be stable once we have entered this code.)
			( if we don't do this we could miss a level raise)
			7 $100 * $2000 + # SR W. MOV

			_xlevel_next AB D0 MOV
			_xlevel AB D0 CMP
			GE IF   ( we don't have to suspend what we are doing and start a higher level)
				R )+ D0 MOV
				\ _%int_stack_pointer will have same value as when we
				\ entered

				A0 R MOV
				R )+ A0 MOV
				RTE
			ELSE
				\ Save CPU state
				R )+ D0 MOV
				A0 R -) MOV  \ User return stack
				8 7 + 4 * NEGATE R) R LEA
				\ we don't have to save A0, but its quicker than two seperate 
				\ MMOV instructions
				\\ D0 A6 \\ R ) MMOV  
				\ save the MAC registers
				MACSR D0 MOV
				D0 R -) MOV
				MASK D0 MOV 
				D0 R -) MOV
				ACC D0 MOV
				D0 R -) MOV
				_xlevel AB R -) MOV 

				\ swap to user stack, the user stack will be used for task switching
				R _%int_stack_pointer AB MOV
				A0 R MOV

				\ Set _xlevel to required value			 
				_xlevel_next AB D0 MOV
				D0 _xlevel AB  MOV
				
				\ Set back to low value as restart has occured.
				#clock_low # D0 MOV
				D0 _xlevel_next AB MOV
				

				\ start the new level, note no level will be previously saved on stack 
				\ as we are raising the level.
				_xheads # A0 MOV
				_xlevel AB D0 MOV
				( Value stored in _xheads, this points to level switching entry)
				[ A0 D0 cell ] A1 MOV        ( first task address)


				\ We didn't test flag as it is asssumed that the level to be restarted
				\ required activation. But we have to reset the flag. The flag
				\ has to be set initially just in case the activation level gets raised
				\ once again.
				FALSE # _#level_head_restart_flag _#level_head_trap - 1) W. MOV

				\ fake stack frame to force return to task starting code
				#activation_task_link 1) R -) MOV
				0 # R -) W. MOV                ( cpu_status)
				$4000 # R -) W. MOV             ( format code)
				RTE
			THEN
		THEN
	NEXT
	HOST		  
		
forth : system_rte	
		4EF9 tw,   \ ##code JMP
		HOST ['] _system_rte t,
	;



HOST
	: system_rte
		4EF9 W,   \ ##code JMP
		['] _system_rte ,
	;
.S .( out system_rte.com)
./version081/multitaskingpaper/system_stack.png0100777000000000000000000001040107300314367020620 0ustar rootrootPNG  IHDR&PLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4D IDATx[FyO̭اb r0?+S[Bɽ-@[2 $ I~~?'ßOQ\%fc3z4 9v +3x s&mOs`W, rYu > $U)X=` MG$ m n.xңsՇ>[iI;?W%Mpցxf8dN.C0WIfk @\ФBf@g=Y/ ]ܶ!Ʈ~|>| =g># H5A@s A*8⓴ -r NĀq 0\)JO8H\$( $  ]a vSAQV޹#t0kxDg0:2Mu:"]f/f K![4tl}< H$e* x}(^S!r" u@D"$r!2ûݝHh"U+y!naȀE(2 D!&!Kܖ|a3,DuwP =,|qTe@Yo gk,t`gK%@J[! >;Aћq6$THf_L>2H^xd.a6H $(pq4A3&^@ YȀE(Dd(ȂJG#V[f<].X<AZ>l%2Z;C`Le,T!ĵ@6~X^3(ң|/W<\Lۀ(ɀ[|G!uܗQ ȀE(2 D! Qd@"BkQۀ|J;,p w ‷@8;'j۟Q4SWou+W)V!tq}R2i.Z9%3@S\z~dzMs.SuX{:"$x 8הugȀE(2 D! QԫK^@~hr+AR"YD?lPEDkJ"?DN2 r"}@D."#r#@fxWw۽XkyˁW;v3;[ȻkJUd@"BȀE(2 DD-i i9@~* &X j;!Vw($ LP9e]Ѝe -}f|L]3H>ez,j!F{b phT/2qF[ zx>\ ?2)fne H<ωRlUٜ@H80a m KڀX'& -O]A CcH]fY&sv ܳH92 d&+̀ i!z')y x j5@*q itiS]9xҔ rr>aay KBAo-C^O$Y\Y} Mv˜ Hw7qtuA喵ȀlHȿӈCx6!hP,uO#!x*6dĬpyJs3l8Wzw 3NPaVL/Hgu_N  qPjC1t-?a Ix}2 Y&2w]r/-H& u#1 !;ebdV 1 M@t5$e%*2 D! Qd@"B5Z3 B +'Y=O`GwHkt6 @EwO4{$kJUd@"BȀE(1eҞ]>Q ##qenkOG$tC?Ǚ5%sYE(2 D! Qd@"B겝|hr+AR"Y?lPEDkJ"?DN2 r"}@D."#r#@fxWw3]"E\EU&+y!naȀE(2 D!&!uVd@XE(2 DPeh5@\Hq R/ x|Cr>\4|s _ ZJC+g"4Na 2Yll'f24t9Bfx@c7rnaה VD! Qd@"S {)b@ 3 A.ڈ1 3 f!d{2 Āb@E wה ȀE(2 D! Qd@+z9 I,h3 eIENDB`./version081/multitaskingpaper/task_loop.png0100777000000000000000000001327307300314367020114 0ustar rootrootPNG  IHDRA0PLTE{FIDATx[* >bLw4"V3}FgM5I.I.I.$ rXR\$O Hr Hr Hr Hr Hr Hr HrIdݑy&)OA($ɢ4HJIp7L$0(dCҵiJId; VH"2Oɖ-?$t-$$ .I.&Uk$o$$|I+Jg]P' , UINyJ27ZtӾu,&]YIh9%0?45UnZƭ'9-F[9vWߟا ";5HÂM~~A#[qII7$WHVnHKR}J_%jZW>*[p_g̵D.$ɏ9e?ǰCkOTMR32JRjFE yd/V }eEΚ٤uYU/z}LrD\|^NmfgM{h"+ɲRyؠF?9O/#iR=싄2f?Q!yI d/HrIn<>Ruj:]^P` H4QxITB4~&LIݠn#)yK2Kw1+ݰ5]GNHK9>q2uq^wZ&Jz,7=G_[1IX GIpʍ{yӎM:Bu6iT٤Hz)~z?KkvM$)G~3}8H$c#iRwO\LR@_㗭XLz*S<ʝ<~f$zIOui$+H2$[I]W'$I #'jI$jI2J;#@&9R=j$92Q@v ق'H$ā$WWd')w[qFI2,/I&ވWI&ܯJduǻ$MޅTf4AR ؀doD-}]h%IZ7[nVɒP[7agy {#N.ߝj=o۽$܏~ҷI} x[}q~6K]W%%ӑg$4fHrΐidyU^@Z6!}Iމ,}IysIW6SSʋ_Iy\ղk_f>9][-6ɽ]\-ꋚ_H{5$+e_m5$ w,][:&9}.ݛE/#ɿ˯-WtsqWH!H䗑L_'yIvg|7T;*;$sJՓ1HM2/4NJzr՘Jd;$?IReN◹(.A;$etGw9>~gq{h$MJs 8.<)I IYSO,bȒ42{_%)0s$E&)Հ0IQ$GIArT I TMr U$¹IΘD6 7|5s'a[$Iu=kAi?3CY*zIYU&YIֺd vM%V"Iu݊]t$4H鞾uUZM$~UJ+$I>fZ6l IOr!I1EIY>OkK{(ɼSHMR>YfY5kW$Y KII5Hn$~&O\IӁ$%o[3x ?ċdYzH[$Hn' fV'n`Dȷ3|| IgdvF S l3|udشƑng$wJH_팾s4mB?vV* og0PaܴpivF mqTrxxd$G%-' G $'p\/ArTr"?%$I$GeS̹/tl$O \$ ɥ*Hr \.D2ߞt $V G 染Kw{=$2*?ԣb Y*g~HRS xc8u's{P_ɻсӁd\@?y .Q|Z7zIӁ$@t u::H6Ts Hvō$>[nIv6';uN)0qt  gs`I ?HF0&M=H&e Fisr&{-WQKڋ/AOK2$+=0A\F.b6w=FɪR ;Q6 @YΫt,Wƻe4oޑo$\@2M6 {2\1ICV']@D˜RaZ<'4?C~AÉŸ>Qz4L볯W'x1"{$U=v\qIJ}@CE6R˲cɸ> b WeyȞ|k;~쯙I>&+j*2#I.I.I.I.I.Ol=& +WRh9@7@ٓ,' H`rd.!Iη{*Mw$HU }@f/~LU.!i'떬θr.$.$.$.$.$.$.Iz=DMrIr U$ʁ$W9*\@HrIr?Lhb8_@HrIr U$DgFCP]$D-$ 6GI;HLV\5!(kiv#$7OE)@ɍV尲Ɍ2ʤ0%5FYdB6yW\$7o"!?+$m 3I#6iv}2-WػMȭ$g'1c7Ho\\\\ r% ɥHr)\ʁ$r$̞]/?=c6y$@rVJ@K9R$I.@K9R$I.@K9R$I.@K9R$I.@Kdg=(rJErRHN.7V Hr)\ʁ$r}$㇡X\nN$5Uar fjO|I DGҭofG۽CƬzv]~n`#[x'‘aLw̆,ll>HI$)h7듴[I,bN$oTl褿ǍEp?%TH&&$]NRzSb]%7Hr+;X%d~#{$ٔ\nRQZ.9Hr)(Ow/-I6e'$I.@K9R$2tr')_ʅH>΃}ΤN[HnIRQl4eH4r*TX U-r*lB qR {.I r(J,q٤j悔]td-TBFHʕHڱ[dajU[v=\ޮ{b$)MeR=Cd1IRm]yY$L4- %Ix|{Ț$&!IkI?yy>Qw=;H lrGI^rc\D$QvrJ@K9R$I.X%X% ɥHr)\ʁ$r ɥHr)\ʁ$r ɥHr)\ʁ$r ɥܣHb~7ˍU\ʁ$r ɥ/ܓH.- % % % % % %?4I9JWIENDB`./version081/multitaskingpaper/tasking.png0100777000000000000000000001637107300314367017563 0ustar rootrootPNG  IHDRTPLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4DIDATx흋r*@?NRuAyNfg>N4.VX`+,X` IV'L([*=j &=OjMbZή:+O+e!V\Rb5+e!V\Rb5+e!V\ȝavMCyhB>{^,]"ioEy,Xt"z_jEcEZ.dņXiY; ek (0Z{lߏoD=ӛVUrqj/{72$V(JW,m!=-5?²6kŰtXAi8 U, 1J!}E682JgQ!ZՊ!c lH%dʊ%'!1X-s%ud.UziE.ۋZd?i+d2=tcǂZa 3B 3DCIJÊ1Waŗi'_[)B%dfB} {b9<*Ԋy+˅{jWي-ߘ6o}ݶ $d0"1?ŊXʭ#t12a+6[!UAqZ}%;Ŏ1b-V#0}?as~+>c$OVx@]ϙ3=$eT}"e9 (q,$[{nr\풽{s:{_oEaXѲ^h V\) `ŕ+V\) 0K~D.Dޣ+,X` VX`+,X` VXl8;k8;K`+,X` VX`$+ΞBr{(ܒy%=O׉>~8u_'I}XqlӭN.^'ئ[}\N$cűM:xHNJcn]ur:Ǐv]س94WYW+M((ҢِY{"Z ƊPTs=X*ot尅>VrVlh5VX ^}S[[DTkp͇EQѼueK9kiܑVͿ4Y!w:3be2t%reˆ8F?E21ch|Mo›JvW:S'/b0g\\#h/d#[ejw#+|F2Ø>3wdG_aŘΙ$ҙ }3TV%>J\&"+Ų~?GPJ:JguFVC(yJ)#ˆV2QnbŰyY{]+*q>s+ZşhjDAbGPpʬܑ}E*'3Vh,vϹ#o⍗N%s${838Ԋ6[!>^r{HwЩJrNVx_<׊@kjR;ߊW$[Pur:ߙv%XqHNJcn]ur:Ǐ6ݺu"YvmP<؜SfFM_`+,X` VX`+,X` VX`+,X` VX; ye= =kmYN.^'Cv+o7+:n7+:n7+:n7+:n7eγ9hzSm{J2!ZQ3#W{ɇ~Q.kE~zBvQ{XkEE7jEjT=Y+!VljVXblח^ds?\-߫0=ʹ,n pD&|N~oS.{ّC5>2T["y}C9.4!T*}go.vQ6jҕ^ "J"5׭ym,4 L#(Abs\筣=Aq:7¶).J^#t+%;Ȋmo(+reI>!t{zHU`\䕴ΊL+5VDeXWػmV贍Pn_aDKbX=ZYkp2#<@Ŋ]lx_ WWFP\m%VdہwRWs0B)rK#yy+?"qvŮs egW2K^ mZ+{>}-{,JFPķQ rN]oL{e`.u{]O]bnrd!Xm ggb7M6deԽκֽF\CFPfoY }œaMaMaMaM9ˊG1O$+. VX`+,X` ˝ߟhÝps+Ā(+%ytHPͭV<;[q%%xwb`cf`cf`cf`cf`cf`cf`cf`cf`c8Ɋk=ﻯe?3K9o𾜝m͞XOM:Wi+Xl+x Xl+x Xl+x Xl+x X]6lu9+Bسʮ Eq d嫰V\W^EȭgE(*E XݾXVXaXVe>|TߏOӇjmSŤv%R"41rzߛ67- V,9%L3p%K9Ycj?֊Agb+T"2#EN/)t QmKQ!Z%'68?2EЭH+ Z)ӕh1dV|Q%KV8.jQo/bˤI* sͪ)"#ĊI-bAuVլŸƊGMЊ[6B}{$^>+,f KT[bH bI6Z1ݡ#Sq^oE}cƭC(A$SIc'gdEbs?c 9_y58| *nݛlCs)?{jyt|Ufő{4T+n;O]= ;"Lϣ">6n_+WrNW}EJW`Ŷ{f+ͶŠ$Xq\X}8ˊGHW͒`+,X` VXb7=;`YF+7)1ۊ/>5V{_ 8 ĸ.Xq"qQ`+=??gGPVXd3#9Ej&)^iw3xV"㒨X8)Igh V4Ns+tƊ`E8')X?ǽ+VdVd"f]ٱO ae{݊PPjoE~+BgE(**6ꛯpM+B+Bފll #}YR~]0bK kV֊ϧg~|B>kUkM$&>FL:DF;+Դ1 },bZo|?4c|22D|L#em֊(\(X^}Xnz]|Tf<$ZΊA! Ϡ,j^L0m8ײbeőΊfL;}㣵!v;~ +fnmE/;XT-{l ;ӳJW4]m:cESqRXh3V4+'9M9ˊI ,>tc+,X` VX`+M~wG`#XqQb (MJ Xr6L*>/%ʫluĸ.Xєm+B?h V<h V<h V<h V<h V<h V<h V<h V<lʗԛ+n"W6,_ussfWi6`y]'5n2եb] 켮Lϓ 7Rԅrv^WIbLutWB9;+fMTl+uוoh]w/lEfWr{i[ H_Ɗ@Yʭ:VO|aŊp+v +>h1>[%hqA)asXwO{6i#ɉhd>= XGùeZv+cK E"!hgb+T? Z1+/^ PW,0J|NbUO?7׭y줮xi=*1DYQ0՘֊a9@DV蔖[΢d5^.תVfNT2|BcŐ¤m,HK5Sbq"%VլŸʊǮ)gEbe+f|}03H|_Q~_݊@+Y>YY SZ+Ao *VdA$a2<:؊ z?3(>Š:!N렓;cE$Y)=Xq(X$sؗMw.}_nEeECZQer+jŦJZ%.}E<'v.J](tcEYX&S]*6ݕPƊfMTl+uӍebLutWBѧ+ʚ}(̒6O7VXYX[fanПeV@YX[fanПeV@YXq"bF,^pŠSx2|@ݜVa/Q^Vb\8ĸ(X` VX`+,X` VX`+,X`V#6DYQg;X` VXZXQt}:܆VJ{%=:[9 jAgQo/~WM%j]<׭Kþ",U2OK-5 ^ Fj-h:-5 - j!BTpz1Qp4}p+ p mGPAңAfPQϴx7>H_177G_H 3 ` VX`muVXg~vmMjTcv>8Њ^|;|%jygEs4)HAv݂ 1ioVO*z~5sMOgU-9ƬelVzOdٞTSFeh2>xˣ>qu9܄PTZ_iTDV-3P+J+ĸHwPnG j7me_fnhxE4Fo>w2^x Ww}.Z|_.OWlm- Ϧ~bXTr"A2y8nӮ)珘!R4ܐV-H +nF4F2+TRW͏dxjdUYٻx`+, `mg`+,}0.Oxe< SV@O"`ފvA4,ӓT)k5"̉r3?,j\+sTŠy?t|2MEji5M⃗Ȋa{4IN2^F+ go"ej!aXBZ< ݎN\5ϕm$n~,hc>񑣑|CG \W͛VŠۓ}x%X1"+ 9|+^+,X` 9>"`+,X` VX`+,X` VX`+,X` VX`+,X` VX`+,X` VXO1wi IENDB`./version081/multitaskingpaper/traps.html0100777000000000000000000002720107300314367017426 0ustar rootroot COLDFORTH KERNEL license 
 
 .S .( Into traps.html)
	\ Have ago at aborting process
	: _abort_access_error TRUE ABORT" Access Error" ;
 	interrupt: TRAP02
		save_fault_stack

		panic_cr
		panic" Access Error" 
		panic_stack_frame
		panic_cr
		panic" Offending code"
		_#int_A7 @int_stack_frame _#int_user_return + @ $40 panic_show
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		['] _abort_access_error int_return!
	;interrupt

	\ Have an attempt at abort the offending process
	: _abort_address_error TRUE ABORT" Address Error" ; 
 	interrupt: TRAP03
		save_fault_stack
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Address Error" 
		panic_stack_frame
		panic_cr
		panic" Offending code"
		_#int_A7 @int_stack_frame _#int_user_return + @ $40 panic_show

		['] _abort_address_error int_return!

	;interrupt
	
	\ Have an attempt at aborting the offending process
	: _abort_illegial_instruction TRUE ABORT" Illegal Instruction" ;
	interrupt: TRAP04
		save_fault_stack
[ #BCM550 [IF] ]T		
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Illegal Instruction" 
		panic_stack_frame
		panic_cr
		panic" Offending code"
		_#int_A7 @int_stack_frame _#int_user_return + @ $40 panic_show

		['] _abort_illegial_instruction int_return!

	;interrupt


	\ have an attempt at aborting offending process
	: _abort_priv_violation TRUE ABORT" Privilege violation" ;
	interrupt: TRAP08
		save_fault_stack
[ #BCM550 [IF] ]T		
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Privilege violation" 
		panic_stack_frame
		panic_cr
		panic" Offending code"
		_#int_A7 @int_stack_frame _#int_user_return + @ $40 panic_show

		['] _abort_priv_violation int_return!
	;interrupt
    
	
	\ acceptable behavior
	interrupt: TRAP09
		save_fault_stack
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr 
		panic" Trace"
		panic_stack_frame
	;interrupt

	\ Have a go at aborting offending process
	: _abort_line_a TRUE ABORT" Unimplemented line A code" ;
    interrupt: TRAP0A
		save_fault_stack
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Unimplemented line A code" 
		panic_stack_frame
		panic_cr
		panic" Offending code"
		_#int_A7 @int_stack_frame _#int_user_return + @  $40 panic_show

		['] _abort_line_a int_return!
	;interrupt



	\ have a go at oborting offending process
	: _abort_line_f  TRUE ABORT" Unimplemented line F code" ;
	interrupt: TRAP0B
		save_fault_stack
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Unimplemented line F code"
		panic_stack_frame
		panic_cr
		panic" Offending code"
		_#int_A7 @int_stack_frame _#int_user_return + @  $40 panic_show

		['] _abort_line_f int_return!
	
	;interrupt
    
	\ This is acceptable behavior
	interrupt: TRAP0C
		save_fault_stack
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Debug interrupt" 
		panic_stack_frame
	;interrupt

	\ we are not likely to be able to recover from this one
	interrupt: TRAP0E
		save_fault_stack
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Format error" 
		panic_stack_frame
	;interrupt
 
	\ just return from this
	interrupt: TRAP0F
		save_fault_stack
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		panic_cr
		panic" Unimplemented interrupt"
		panic_stack_frame
	;interrupt

	: _abort_bus_error panic" In abort code" TRUE ABORT" Bus error" ;

 	interrupt: TRAP1F
		\ reset interrupt, must be a write
		zero _breg_int_reset_bus_error C! 
		save_fault_stack
		panic_cr
		panic" Bus Error" 
		panic_stack_frame
		panic_cr
		panic" Offending code"
		_#int_A7 @int_stack_frame _#int_user_return + @ $40 panic_show
[ #BCM550 [IF] ]T
		_breg_SS1 C@
		_#SS1_processor_fault OR
		_breg_SS1 C!
[ [THEN] ]T
		['] _abort_bus_error int_return!
	;interrupt

All this is being done on the stack of the task that was running at the time. It really is best done in assembler so the stack space that has to be provided by each task to interrupt service is kept to a minimum Oh for the 68k.

This is a task switch within a loop. The task switch can use registers as any normal forth word would. That is A0 A1 and W ok etc. Actually you can use more as LP, and OP have been saved off. 

 
	CREATE TRAP22 assembler
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled, or switch back to user
		\ space, all this can be done in user space
		$0000 # SR MOV
		R )+ D0 MOV ( pop cpu status and format )
		R )+ A0  MOV     ( return address)
		\ the return address points to the instruction after
		\ the trap instruction, the trap instruction is two bytes.
		#activation_trap 2+  # A0 SUB  ( activation base address)
		
		#activation_task> 0) U MOV

		zero # D1 MOV
		#activation_status 0) D1 W. MOV  ( status)
		sleep # D1 CMP EQ IF
			\ we have to get the next tasks  trap instruction
			#activation_task_link 0) A0 MOV \ address next instruction
			A0 ) JMP
		THEN
		wake # D1 CMP EQ IF
			sleep # #activation_status 0) W. MOV    ( only one activation)
			(S) U) S MOV
			S )+ R MOV   
			S )+ OP MOV
			S )+ LP MOV
			EXIT
		THEN
		test # D1 CMP EQ IF
			#activation_task_link 0) A1 MOV     ( next task in loop)
			_task_restart_time user_base - U) D0 MOV    ( activation time)
			xclock- AB D0 ADD CS IF
				A1 ) JMP  
			THEN  ( Go to next task if not ready)
			(S) U) S MOV   ( stack pointer restored)
			S )+ R MOV     ( return stack pointer)
			S )+ OP MOV
			S )+ LP MOV
			EXIT
		THEN
		\ For unknown codes treat as sleep
		\ we have to get the next tasks  trap instruction
 		#activation_task_link 0) A0 MOV \ address next instruction
		A0 ) JMP
	HOST

	??HEX
	\ stop the CPU    
	LABEL TRAP25 ( reset) assembler
		7 100 * 2000 + # STOP
		BEGIN 
			D0 D0 ADD 
		BRA
	HOST    

    ( Execute code in supervisor mode)
	LABEL TRAP26
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		8 # R ADD  
		S )+ R -) MOV 
		2700 # R -) W. MOV
		4000 # R -) W. MOV ( format code) 
	RTE

Swap task levels

We enter this code with R set to a user stack. If there is a suspeneded level it will be stored on the system stack. 

 
	\ These two flags are tested as one in the following code.
	_#level_head_restart_flag 2 + _#level_head_repeat_flag ??=
	
	LABEL TRAP27 assembler

		\ if we are in supervisor mode and not using the 
		\ interrupt stack we have to have interrupts disabled.
		2700 # SR W. MOV       ( no interrupts)
		
		\ hardware interrupt frame. Need the entry address as 
		\ the switch level is stored in the word pointed to

		4 # R ADD \ don't need status
		R )+ A0 MOV \ need address for table entry

		\ switch to system stack, we have to save the user stack pointer
		\ it will be used later on if there is not a user state saved
		\ for this level.

		R A2 MOV
		_%int_stack_pointer AB R MOV

		
		0 # D1 MOV
		_#level_head_next_level _#level_head_trapPC - 0) D1 W. MOV         ( level to swap to)
		D1 _xlevel AB MOV       ( save as level we are about to run)
		 
		R ) D2 MOV              ( stacked cpu state, with level on top)

		\ level suspended

		D2 D1 CMP EQ IF         ( this level has been suspended)
			4 # R ADD         ( drop level )
				\ save the MAC registers
			R )+ D0 MOV
			D0 ACC MOV
			R )+ D0 MOV
		    D0 MASK MOV 
			R )+ D0 MOV
			D0 MACSR MOV
    		R ) \\ D0 A6 \\ MMOV
			8 7 + 4 * R) R LEA
			
			\ we now have to use the trap return frame that was there when 
			\ suspended the task.
			\ Further _%int_stack_pointer has to be updated to 
			\ point to next frame.

			R )+ A0 MOV          \ user stack
			R _%int_stack_pointer AB MOV
			A0 R MOV

			R )+ A0 MOV
			\ because interrupts are disabled RTE will do
    		RTE           ( the return state was saved when the level was suspended)
		THEN

		\ ? level to be restarted, switch back to user stack and get things going
		A2 R MOV
		_xheads # A0 MOV
		[ A0 D1 4 ] A1 MOV        ( first task address)

		_#level_head_restart_flag _#level_head_trap - 1) D2 MOV 
		NE IF 
			FALSE # _#level_head_restart_flag _#level_head_trap - 1) W. MOV
			( First task is linked into the level swiching entry)
			#activation_task_link  1) R -) MOV    ( next task in loop)
			$0000 # R -) W. MOV         ( New status)
			$4000 # R -) W. MOV         ( format code)
			RTE
		THEN
		
		( execute the head of the new level )
		( This will have us straight back to deal with the next.)
		A1 R -) MOV
		0 # R -) W. MOV  ( New status)
		4000 # R -) W. MOV
	RTE
	HOST   
    
    
	( Change interrupt level)
	LABEL TRAP28
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		%int_enable AB TST NE IF
			D0 R -) MOV
			4 R) D0 W. MOV
    		F8FF # D0 AND
			D0 4 R) W. MOV
			R )+ D0 MOV
		THEN 
	RTE
    HOST

	LABEL TRAP29	
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		%int_enable AB  TST NE IF
			D0 R -) MOV
			4 R) D0 W. MOV
			F8FF # D0 AND  
			0100 # D0 OR
			D0 4 R) W. MOV
			R )+ D0 MOV
		THEN 
	RTE
	HOST

	LABEL TRAP2A
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		%int_enable AB TST NE IF
			D0 R -) MOV
			4 R) D0 W. MOV
    		F8FF # D0 AND  
			0200 # D0 OR 
			D0 4 R) W. MOV
			R )+ D0 MOV 
		THEN 
	RTE
    HOST

	LABEL TRAP2B
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		%int_enable AB TST NE IF
			D0 R -) MOV
			4 R) D0 W. MOV
    		F8FF # D0 AND  
			0300 # D0 OR 
			D0 4 R) W. MOV
			R )+ D0 MOV 
		THEN 
	RTE
    HOST

	LABEL TRAP2C
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		%int_enable AB  TST NE IF
			D0 R -) MOV
			4 R) D0 W. MOV
    		F8FF # D0 AND  
			0400 # D0 OR
			D0 4 R) W. MOV
			R )+ D0 MOV 
		THEN 
	RTE
	HOST

	LABEL TRAP2D     
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		%int_enable AB  TST NE IF
			D0 R -) MOV
			4 R) D0 W. MOV
    		F8FF # D0 AND  
			0500 # D0 OR 
			D0 4 R) W. MOV
			R )+ D0 MOV 
		THEN 
	RTE
    HOST

	LABEL TRAP2E
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		%int_enable AB TST NE IF
			D0 R -) MOV
			4 R) D0 W. MOV	
    		F8FF # D0 AND  
			0600 # D0 OR 
			D0 4 R) W. MOV
			R )+ D0 MOV
		THEN 
	RTE
	HOST

	LABEL TRAP2F
		\ if we are not using the interrupt stack we have
		\ to have interrupts disabled.
		2700 # SR MOV
		D0 R -) MOV
		4 R) D0 W. MOV                    
		0700 # D0 OR 
		D0 4 R) W. MOV
		R )+ D0 MOV 
	RTE
    HOST
./version081/setting_uptcp_server/0040700000000000000000000000000007303262400016073 5ustar rootroot./version081/setting_uptcp_server/paper.html0100777000000000000000000001225207300314367020117 0ustar rootroot COLDFORTH KERNEL

INTRODUCTION

COLDFORTH allows a program to start a new tast at runtime. COLDFORTH allows a task to destroy inself. It is simple to write a COLDFORTH server that listens to a port and when a remote machine calls, creates a handle to look after the connection and creates a task to deal with the work.

You can get a general overview of the serving task by looking at the telnet_server

The follwoing code creates the server task. Not very long, is it. 

 
#clock_low task: telnet_server
             $" tcp_server/#23" 0 $open
             \ change the generated client to a telnet client 
             [ tcp_telnet ]T LITERAL OVER :client! 
             %tcp_telnet_server !
             BEGIN
                     %tcp_telnet_server @ :listen
                     start_task
             AGAIN
             ;task

We will now go through it line by lines. $" tcp_server/#23" 0 $open returns a handle to object that can handle all tcp datagrams received on port 23. The method listen deal with the initl opening seqence from a remote machine and creates another object that deals with tcp datagrams for 23 from a particular machine and port on that machine. The type of object created is refered to as the child.

After the server creates the child it takes no further interest in the connection. It is yours to do with what you like. The demux come will sent packets that belong to the connection to the child and will do so until the handle is closed.

For the handle to be usefull you have to read or write data to the new handle. You can have the current thread do that, but if it is it can't be listening for additional requests for service on the original handle. Tyhe solution is to create a new task and give it the handle.

The next line [ tcp_telnet ]T LITERAL OVER :client! in the above code changes the type of client produced. The standard tcp_server will create s client that will receive and send data and that is it. A telnet client has to deal with "WILL", "WON'", "DO" and "DON't". We could have created client as bad as the windows NT client, but we didn't telnet is supported well enough to allow remote line editing. For most application the default client gives the desired result. You can write your own client but it does require a greater knowedge of the system. This line is usually not needed.

The next line %tcp_telnet_server ! stores the address of the server handle in a globel variable, this is only done for debug perposes, you can leave the handle on the stack if desired, %tcp_telnet_server !

The next few lines perform the server function. The :listen method of the server is called, it returns with the handle of a :cild object only when a remote machine makes a conection. The code then calls start_task to create a child task to look after the new handle.

The COLDFORTH telnet server handles multiple connections.

Starting the child task

The following is the code used to create the child task. 

 
: start_task  ( client --) 
	one ['] telnet_action #clock_low $telnet_child child_task
;

The code only deals with setting up the stack for the word child_task. COLDFORTH has a neat way of dealing with a new tasks. FORTH exposes the stack, child_task allows you to set the new tasks initial stack. How the the new task uses the initial stack data depends on the new tasks code.

The stack description for child_task is:

( ?? number task_word priority description_string --)

Where:
numberNumber of stack items to be transfered to the child.
task_wordThe execution token of the word to be executed by the new task.
priorityThe priority level the new task is to be placed on.
description_stringThe name the task is going to be called.

So the code above supplied the new task word with one stack item, in this case the handle returned by the servers :listen method.

The child task

From the description above and the code it is obvious that the word executed by the child task is called telnet_action, the code for that word is. 

: telnet_action  ( handle -- )
	DUP 'output_file !
	DUP 'input_file !
	'abort_file !
	prompt
;

All this word does is install the supplied handle as the default input, output and error path, and execute the word prompt. There is nothing special about the word prompt used by the telnet chid, it is the used by all tasks the supply forth interpretation. If however you dig into the :child code you will find that a loss of connection will result in the deth of the child task.

./version081/tcp/0040755000000000000000000000000007303262345012425 5ustar rootroot./version081/tcp/arp_entry.png0100777000000000000000000001035707300314371015142 0ustar rootrootPNG  IHDR a؅+0PLTE{zIDATx b @7pẀM"t++7F x#oăMy$~;"x?q9_L_Y8Ə_Ճ!߭9z}%=чMۤ#ehŏ{owux{}L⏾_g,Ə?牍cVS Y#oħS1Lyylo@7F ވ/4!~l);_.~^WX8*Z!piɒpK1 y[){ai^rШ/Uz]7]){aZnW|Z.jƳex w?^_A&ynd}o19nvPWEν{l?#>TTA[UԳ:a'~aV˕ߗ!/;Nt@7弚}7 {{z@^2 ī%z@^2//hk|~X,lhy_\~]|s"-߁7z|~x}Ozms\|M.>i_N}mH+ )M#>rRepć4 pv48AG|XBG948oߺ syvkIG5^2&mH~@^2 ī%z@^2 Cy51-zWDC|6WKxud ^]/6עtVt"w]{vxhWF}偦be/G~Ļ,ǥAn*+]9?* n*:ӃYk֓qĻ]BT/6 ~JfaYKyڦW4WKxud ^]/WKxߗxp>TaC ZDĿx,|%Ad[zr/E5^_?r #^@Ck?xy%ʨ_hy9)^@Ck O{9/c]E|d[*"3P0MG) 14Meא/5jV3=C4h?'sGȣr 1y*jf+WkcħM >\"'^CW@j%'%"=ZkV{Be*yh-G| !~yKؙ ! ,-,=Ιj9kZQ 1/5%_|)}wN&>y/v# (ؐ,o O\*c]1|g4_w!bV)zZxJD+ ^{h ZDĿⵇV+jɫ KD+ ^{h ZDĿ d@5/g-_xZXWjKLς.ořį v?ˍ]e]L5V)|nYSZ~3X=<~ė'5/OjE:)Jjg5eIM=% ^{h ZDĿⵇV+y5!Մ%"=Z;i K M i+J< e&/%)1>[CİdG 7+J OwxkJ >-#>\bH<C,1 JG|Ā*b"cC0]#=< ^GYg -z@^2 ī%H((&[Pt#qb6ZyyZ/-S,nyK[y4wɷ1w!~8z3o_3Յ]?a~~ⷝ54l0ԌyI9YCSO?ρ1~ >#.jmGxf5ysz+׼9=Ⳃ# 9Iv ^]/WKxud_ y5w xud ^]/& LZH3ao-LB]8\O@ڗw!9r^ M/ vKF\4q*OȲZaB) p =~ϒ:1CY??0U?2mkӎĻ:ݓލ_S3{4=pˆiM5j-4 $ƃ[bf)6!xL䖵mwZnSl}ۼ=gXwZ>Os7~Vi;l]u B[6g:<ݶphVxtxW;Yk.w, /IHrnZRx#7n%Oaߍ蒮lֶ]+XnU7Z+O-_ ~#kR@-xXz}c8XT?'-BiID4<"{\#`n \>[XH0P7ZƗ$܂ ?'- ne F1>`p .-`02yL0Ojur9B;!^<&^Y|Il ī%z@^2ȫ#?@7F x#~^U)?,F xF| z݉&/t+ަ݊Q %ts[#-ٶ\ₗavJ"Ա on`Y-W61ˮK!G\ d߷\]ua}=C[oNЋ_&}>b.SZ T wwu1>>nbh^H4);_*/~_ⳋA|8;y1_y9JRG놯fėG|n1o+֯r1o'j~Q|[#5㶷Tl"^.Vv{.~ieVdq?/~nhV.T:?n8C?H5Ȟ5m:4/cҬUن13>yߜdpj|c*/. >W6W ++m͕J[xes@V >_WӇ++m͕J[xes@V"jHF x#o@7F x#o@7jx#o@7F x#o@7F x#o@7F x#o@7F x#o@{,(P=f=/$7!cf,['12n 10"~%iH|aD~CeÈxP|Tm#{/MoⅦ)[:/55:KM=Y_K|~x`_`[@7F x}k6WZ67F x#o@7F x#(gIENDB`./version081/tcp/demux.html0100777000000000000000000000636707300314371014447 0ustar rootroot COLDFORTH KERNEL license

The protocol deals in numbers, from the number we have to extract an object to deal with the packet

It must be possible to add entries to the demux table from anywhere, while the table is in use by others.

Bucket_structure 

 
	zero
	DUP CONSTANT _#demux_bucket_fwd_link CELL+
	DUP CONSTANT _#demux_bucket_bck_link CELL+
	DUP CONSTANT _#demux_bucket_key      CELL+
	DUP CONSTANT _#demux_bucket_users    CELL+
	DUP CONSTANT _#demux_bucket_object   CELL+
		CONSTANT _#demux_bucket_length

Find list to search 

 
	: demux_hash { ( value table num_entries-- addr)  }{
		variable %small_buffer }
		ROT %small_buffer !
		%small_buffer 4 checksum 
		\ table num checksum (--
		SWAP 
		\ table check num(--
		1 - CELLS
		\ table num mask(--
		AND
		\ table offset(--
		+
	;

Find an entry 

 
	: demux_find ( value table num --addr|0)
		jump >R demux_hash
		R> SWAP
		\ value list(--
		_lock_word	
		BEGIN
			@ DUP
		WHILE
			2DUP _#demux_bucket_key + @ = IF
				\ value list(--
				1 OVER _#demux_bucket_users + +!
				_unlock_word
				NIP
				EXIT
			THEN
		REPEAT
		\ value 0(--
		\ not found
		_unlock_word
		NIP
	;

Add entry to mux table, if entry is not present. 

 
	CREATE $in_use ," In use"
	: demux_add { variable %object variable %value 
		          variable %table  variable %num_lists -- ( $|0 ) }{
			variable %bucket }
		_#demux_bucket_length get_free_buffer %bucket !
		%bucket @ _#demux_bucket_length ERASE
		\ object value table num(--
		%value @ %bucket @ _#demux_bucket_key + !
		%object @  %bucket @ _#demux_bucket_object + !
		1 %bucket @ _#demux_bucket_users + !
		\ value table(--
		%value @ %table @ %num_lists @
		demux_hash
		\ list(--
		DUP
		\ list list(--
		_lock_word
		BEGIN
			@ DUP
		WHILE
			DUP _#demux_bucket_key + @ %value @ = IF
				\ already an entry
				_unlock_word
				\ list list(--
				2DROP
				%bucket @ kill_free_buffer
				$in_use
				EXIT
			THEN
		REPEAT
		\ we can use
		\ list zero(--
		DROP
		\ this will unlock
		%bucket @ SWAP link_double
		\ need the address to see if the entry is valid
		zero
	;

Release entry. 

 
	: demux_release ( addr --)
		_lock_word
		-1 OVER _#demux_bucket_users + +!
		DUP _#demux_bucket_users + @ not IF
			\ this will unlock
			DUP unlink_double
			kill_free_buffer
			EXIT
		THEN
		_unlock_word
		DROP
	;

remove_entry. It is assumed that the object will remain untill the entry is removed, as the object must be valid, and we don't remove it. 

 
	: demux_remove ( value table num --)
		demux_find
		\ addr(--
		?DUP IF
			\ once for the find
			DUP demux_release
			\ once for the add
			demux_release
		THEN
	;
./version081/tcp/demux_socket.html0100777000000000000000000001617607300314371016016 0ustar rootroot COLDFORTH KERNEL license

Demux connection allows the souce machine and source port to become part of the demux equation.

It must be possible to add entries to the demux table from anywhere, while the table is in use by others.

A dest port ( thats us) can have more than one entry that will resolve for a given src port ip, and dest port combination. The match that has the most bits set in the scr_port and scr_ip masks is the one we want selected.

Thus duplicitry occues because a server wil first lisen to a port, if a trasaction is start a socket is developed. This receive datgrams detined to the same destination port, it is now src port and src machine specific.

Bucket_structure 

 

	zero
	DUP CONSTANT _#demux_fwd_link      CELL+
	DUP CONSTANT _#demux_bck_link      CELL+
	DUP CONSTANT _#demux_local_port    CELL+
	DUP CONSTANT _#demux_users         CELL+
	DUP CONSTANT _#demux_object        CELL+
	DUP CONSTANT _#demux_sort          CELL+
	DUP CONSTANT _#demux_remote_port       CELL+
	DUP CONSTANT _#demux_remote_port_mask  CELL+
	DUP CONSTANT _#demux_remote_ip         CELL+
	DUP CONSTANT _#demux_remote_ip_mask    CELL+
	\ only used if needed. Needed by TCP
	DUP CONSTANT _#demux_time          CELL+
	DUP CONSTANT _#demux_try_time      CELL+
	DUP CONSTANT _#demux_live_time     CELL+
		CONSTANT _#demux_length 

	\ doesn't have to be just a warning that you have increased the buffer 
	\ size required to make a table entry with the latest addition to the data
	\ structure
	_#demux_length $80 _#sys_buffer_user - > ??

	\ we use #demux_release so make sure the following is true
	_#demux_bucket_fwd_link _#demux_fwd_link ??=
	_#demux_bucket_bck_link _#demux_bck_link ??= 
	_#demux_bucket_key _#demux_local_port ??=
	_#demux_bucket_users _#demux_users ??=
	_#demux_bucket_object _#demux_object ??=

	 
 
	\ count the number of bits in the mask
	: _mask_bits_set ( x -- n )
		zero
		$20 0 DO
 			OVER 01 AND +
			SWAP
			2/
			SWAP
		LOOP
		NIP
	;

Find an entry; you will note that the destination ip is not included, your destination is a machine not a specific ip on that machine. If your executing this code the ip has been routed to the machine, and there is no need at look at the destination ip. If we reply we do have to make sure the ip is not to a broadcast address. And we do have to use the same ip address that was used to send the message to us, as the sending machine is not likly to know that multiple ip addresses are the same machine. 

 
	: demux_socket_find { 
					variable %local_port 
					
					variable %remote_ip

					variable %remote_port 

					variable %table 
					variable %num --  ( addr|0) }

		%local_port @ %table @ %num @ demux_hash
		\ list(--
		_lock_word	
		BEGIN
			@ DUP
		WHILE
			\ destination port has to be equal
			DUP _#demux_local_port + @ %local_port @ = IF
				\ source port has to be tested, the and value may make it a null test.
				DUP _#demux_remote_port + @ OVER _#demux_remote_port_mask + @ %remote_port @ AND = IF
					DUP _#demux_remote_ip + @ OVER _#demux_remote_ip_mask + @ %remote_ip @ AND = IF
						\ we have the entry
						\ list(--
						1 OVER _#demux_users + +!
						xclock+ @ OVER _#demux_time + !
						_unlock_word
						EXIT
					THEN
				THEN
			THEN
		REPEAT
		\ 0(--
		\ not found
		_unlock_word
	;

Add entry to mux table, if entry is not present. 

 
	\ time for entry to live if noone updates. Only relevent
	\ if there is a time routine to delete the entries.
	\ set tp 2min.
	 #1sec #120 * CONSTANT #demux_time_to_live
	
	CREATE $in_use ," In use"
	: demux_socket_add { 
			variable %object      \ the object that contains the :proto_demux method
			variable %local_port   \ always set
			variable %remote_ip      \ the src machine is the other machine
			variable %remote_ip_mask \ mask can make relevent or not
			variable %remote_port    \ mask can make the scr port relevent or not
			variable %remote_port_mask 
			variable %table       \ the table the entries are linked into.
			variable %num_lists -- ( $|bucket 0 ) }{


			variable %bucket
			variable %sort 
			
			}
		_#demux_length get_free_buffer %bucket !
		%bucket @ _#demux_length ERASE
		\ (--
		%local_port @ %bucket @ _#demux_local_port + !

		%remote_port @ %remote_port_mask @ AND %bucket @ _#demux_remote_port + !
		%remote_port_mask @ %bucket @ _#demux_remote_port_mask + !
		
		%remote_ip @ %remote_ip_mask @ AND %bucket @ _#demux_remote_ip + !
		%remote_ip_mask @ %bucket @ _#demux_remote_ip_mask + !

		\ ip specific before port specific.
		%remote_ip_mask @ _mask_bits_set 8 LSHIFT
		%remote_port_mask @ _mask_bits_set +
		DUP %bucket @ _#demux_sort + ! %sort ! 

		%object @  %bucket @ _#demux_object + !
		1 %bucket @ _#demux_users + !

		#demux_time_to_live %bucket @ _#demux_live_time + !

		xclock+ @ %bucket @ 2DUP _#demux_time + !
		_#demux_try_time + !

		\ (--
		%local_port @ %table @ %num_lists @
		demux_hash
		\ list(--
		DUP
		\ list list(--
		_lock_word
		BEGIN
			@ DUP
		WHILE
			DUP _#demux_sort + @ %sort @ = IF
				DUP _#demux_local_port + @ %local_port @ = 
				IF
					\ The machine address has to be equal ( after masking)
					DUP _#demux_remote_ip + @ OVER _#demux_remote_ip_mask + @ 
					%remote_ip @ AND = IF
						\ the scr_port has to be equal after masking
						DUP _#demux_remote_port + @ OVER
						_#demux_remote_port_mask + @ %remote_port @ AND = IF
							\ already an entry
							_unlock_word
							\ list list(--
							2DROP
							%bucket @ kill_free_buffer
							$in_use
							EXIT
						THEN
					THEN
				THEN
			THEN
		REPEAT
		\ we can use
		\ list zero(--
		DROP
		\ we now have to scan down list until sort key in list is greater or equal.
		\ This links us in from more specific to less specific.
		BEGIN
			DUP @
		WHILE
			DUP @ _#demux_sort + @ %sort @ > not IF
				\ can link in here
				\ this will unlock
				%bucket @ SWAP link_double
				\ need the address to see if the entry is valid
				%bucket @
				zero
				EXIT
			THEN
			@
		REPEAT
		\ get here we are at the list
		\ can link in here
		\ this will unlock
		%bucket @ SWAP link_double
		\ need the address to see if the entry is valid
		%bucket @
		zero
	;

	\ trace down relevent list and see if object is in table.
	\ This is needed when objects are closing, the close cannot
	\ finish until table entry using object has gone
	: _demux_socket_free? ( object key table number(--)
		demux_hash
		\ object list(--
		BEGIN
			@ DUP
		WHILE
			2DUP _#demux_object + @ = IF
				2DROP
				FALSE
				EXIT
			THEN
		REPEAT
		\ object 0(--
		\ not found
		2DROP
		TRUE
	;
./version081/tcp/ethernet_h.html0100777000000000000000000001100607300314371015434 0ustar rootroot COLDFORTH KERNEL license 
 
	.S .( into ethernet.h)
	#6                CONSTANT EP_ALEN   \ number of octets in physical address
	EP_ALEN 2* 2 + CONSTANT EP_HLEN
	\ assumption made in code
	ep_data ep_dst - EP_HLEN ??=    

	#60               CONSTANT EP_MINLEN \ minimum packet length
	#1500             CONSTANT EP_DLEN   \ length of data field ep
	EP_HLEN EP_DLEN + CONSTANT EP_MAXLEN 

	EP_ALEN HW_AMAX ??<=

	#3                CONSTANT EP_RETRY  \ number of times to retry xmit errors

	CREATE $EP_BRC $06FFFFFF t, $FFFFFFFF t, \ Ethernet broadcast address

	#1sec 300 *       CONSTANT EP_RTO     \ time out in seconds for reads

Internet Address Resolution Protocol

RFC814 General
RFC826 ARP standard
RFC903 RARP standard
RFC1029 Further notes

 
	01  CONSTANT AR_HARDWARE \ ethernet hardware type code

Definitions of codes used in operation field of ARP packet 

 
	1 CONSTANT AR_REQUEST   \ ARP request to resolve address
	2 CONSTANT AR_REPLY     \ reply to a resolve request
	3 CONSTANT RA_REQUEST   \ reverse ARP request (RARP packets)
	4 CONSTANT RA_REPLY     \ reply to a reverse request (RARP)

This describes the stucture of a arp packet. The fields ar_hwlem and ar_prlen give the length of the last four fields but we are only interested in one format. 

 
	\ structure was called arp
	zero
	DUP CONSTANT ar_hwtype  02 + \ hardware type see AR_HARDWARE
	DUP CONSTANT ar_prtype  02 + \ protocol type contains $0800 for IP
	DUP CONSTANT ar_hwlen   01 + \ hardware address length
	DUP CONSTANT ar_prlen   01 + \ protocol address length
	DUP CONSTANT ar_op      02 + \ ARP operation (see list above)
	DUP CONSTANT ar_addrs        \ sender and target hw & proto addresses follow
	\ the structure is fixed for the case we are interested in 
	\ hardware is six, ip is four, very easy to make bad code using unused options.
	DUP CONSTANT ar_source_ha EP_ALEN +
	DUP CONSTANT ar_source_pa IP_ALEN +
	DUP CONSTANT ar_target_ha EP_ALEN +
	DUP CONSTANT ar_target_pa IP_ALEN +
	    CONSTANT ar_length


	EP_ALEN RTIP_ALEN MAX	CONSTANT      MAXHWALEN    \ maximum hardware address length

	\ the number of link list heads
	$40				        CONSTANT      ARP_TSIZE    \ ARP table size

	ARP_TSIZE 1- CELLS      CONSTANT      ARP_TSIZE_MASK

	\ number of ip packets that can be queued before the arp request is resolved.
	#10				        CONSTANT      ARP_QSIZE    \ ARP port queue size

	\ cache timeouts 

	#1sec #600 *		        CONSTANT      ARP_TIMEOUT   \ 10 minutes
	#1sec			        CONSTANT      ARP_RESEND    \ resend if no reply in 1 sec
	4				        CONSTANT      ARP_MAXRETRY  \ give up after this many tires

The arp cache is used to convert an ip addresses to hardware addresses. This occures when a packet is to be sent. If the address is not available the state is set to AS_PENDING, the packet queued.and a ARP message sent. 

 
	1 CONSTANT _#ae_queue_priorities
	zero
	DUP CONSTANT ae_link_fwd  CELL+
	DUP CONSTANT ae_link_back CELL+
	DUP CONSTANT ae_state     CELL+              \ state of this entry (see below)
	DUP CONSTANT ae_queue     
	                          #queue_list_length
	                          _#ae_queue_priorities *
	                          #queue_data_length + +
	
	DUP CONSTANT ae_attempts  CELL+              \ number of retries so far
	DUP CONSTANT ae_ttl       CELL+              \ time to live
	DUP CONSTANT ae_hwa       MAXHWALEN +        \ Hardware address 
	DUP CONSTANT ae_pra       IP_ALEN   +        \ Protocol address 
		CONSTANT ae_length                       \ length of a cache entry


	\ values stored in ae_state.
	1 CONSTANT      AS_PENDING   \ Entry is used but incomplete
	2 CONSTANT      AS_RESOLVED  \ Entry has been resolved
	.S .( out ethernet_h)
./version081/tcp/fragment.png0100777000000000000000000000510007300314371014730 0ustar rootrootPNG  IHDRefZ¯0PLTE{ IDATx :sKn#(*%Hռu|m/)qHR'6CgqtgrR3{?jMlɔΞtivfms|߼ܻw;zKaq͝y<{aܜL Ggqtƹ_ ::Ct5kנ3Ag\θq :t5kנ3Ag\θq :tN˝϶38:茣38:茣38E.8:E}`Ӭst"}3N{\ ;Y|l۴ggDYl9=c򌤵,u3 M?7g}ΖǞogYf/wwΚ*:x+Ggqtq 3i_We봿3N丹%7FDhW)oRru#rR9i4MYbDbga5n |Gj.FrmŇ:t9s<Ҽ}.FZ_fňu:{ޗJ]Y,|lW' .F_ xǏ[8ks?Y^rL58:D{p"YrRt'tPy\ѭ5gO+A~n_[Is8[y gSzLu.n;:] Y^ʭϕ+ |4{tlνu?Rg:Z/(g~6T >6{ʹY]Ewo:CLz's_gvSaV>{slJkc7pl_>8u4-/{`νug7̹-%ﰜRg[@ھU NST3>Ss#|q~/"|ckCb_T#r7?mҧT#r7>u훷rپ{9WNה6T#r}׺ѰVƚjDΚu>RmM54gMκ }mj"rgh_swg=G9sb{:g uT?םtS9)DT]-q/38:8ptGgq͠m9 :茣3cGg-ujDytgq79:茣3cGgqtǹ 9:茣3cGg-wv>QS?;KtVGN8:茣38:茣38:茣38:X-wv>kΥ6}LɻMqR&k4oD\ٰr49_:tn1]z kf>8K:{/&\ydz}l"MRtGg8uZ=c?;U봙-M_y|]l7KGM\Y^-UGx֗_jɷ?a4-=m]ㅳiM~}^.׭g<1f9*>Sofkx|lffwqvZmv^y (lPm4hݒisV9ӧ]gv茣38;̟Btl]nw]ƙlǜ΂pt&gr,׾XON˃7y&v ::::7uGgݾ:U:{W-F:m5\y:g7k@gqtq ::::vV8:茣3Nv`UkOo2yg$ Igy2J$e12genYYxxxxeXtf:䌤:38:茣38:茣38:茣38:XX=Iu}$0'qV:茣33333\IU8:=:;}3^Pۂڥ38:茣3y/=iߗ=o->3V Yaxxxx; 3u8Cm j8:茣38:茣38:茣38:c.gip.qN tGg9s ::::+>qt{uvrgLFtGg8:茣3&Ggqtq z=msޮ@gGg238:8ptGgq79:茣38:茣38:茣38:茣38:茣38:茣38:Q?mIENDB`./version081/tcp/html.html0100777000000000000000000001052107300314371014254 0ustar rootroot COLDFORTH KERNEL

HTML file

The code open html/file_name will open a tcp link with the gateway and request the file. 

 
ram_variable %html
tcp_client class	
target_also

		cell% instance_variable %%done_get

		m:
			this [parent] :construct
			zero %%done_get !
			this %html !
		; overrides :construct

		m:
			this [parent] :destruct
		; overrides :destruct

String can be: 

 
			/destination_machine/file

The mode determines the priority and the type of service required. 

 

		#80 CONSTANT #html_port

		m: ( addr n mode -- instance )
			DUP %%mode !
			\ the mode contains the priority and mode as required
			\ for tcp header
			%%priority !
			\ /machine/port
			[CHAR] / remove_leading
			[CHAR] / left_split 
			\ addr_machine count_machine addr_file count_file(--
			2SWAP DUP IF \ machine specified
				Sresolve_address %%remote_machine !
			ELSE
				\ no remote machine speced
				ABORT" remote machine must be given"
			THEN
			\ addr_file count_file(--
			[CHAR] / remove_leading
			\ addr_file count_file addr_new

			this :!name

			#html_port %%remote_port !

			\ ask the os for a demux entry, this also provides a local port
			\ as soon as we do this we can start receiving 
			\ datagrams destined to the allocated port.
			\ As no one knows about us it is not likely, but it
			\ is possible.
			\ This adds to the udp demux table.
			\ We are a client, we care about detination machine and port
			this 
			%%remote_machine @ -1 
			%%remote_port @ -1
			_tcp_port %%demux_structure !
			%%demux_structure @ _#demux_local_port + @ %%local_port !
			\ find out if remote machine on local net; 
			%%remote_machine @ 
			%%priority $1C AND 2 RSHIFT 
			route_get ?DUP IF
				\ the standard calls for this; not really needed but 
				\ what the heck
				DUP rt_interface + @ :ip @ %%local_machine !
				\ The rules are. Make the receive mss as big as you can 
				\ and tell the other end when you send the sync. The send
				\ mss is the default value unless the other end tells us 
				\ otherwise. The mss depend not only on the connection medium 
				\ but alsp on the host being communicated with. The other end
				\ may not be able to handle a mss greater than the min.
				DUP rt_gw + @ not IF
					\ we are talking locally; make mss dependent
					\ on mtu. This is very important for us as the
					\ rti bus has a mtu of 8k
					\ see rfc879 page 5 for justification for this calculation
					DUP rt_interface + @ :@mtu ip_options - 
					#tcp_header_end - %%tcp_rcv.mss !
				THEN
				DROP
			THEN
			#tcps_synsend  %%tcp_state !

			\ This adds the object to the transmit list. After this
			\ things are started
			\ the TCP/IP system is trying to get the SYN packet out, and will deal with
			\ the ack received.
			xclock+ @ tcp_transmit
			this
		; overrides :Sopen


		#cr $0D ??=
		#lf $0A ??=

		CREATE $crlf
			$020D0A00 t,
	
		: _(do_get)  ( --)
			S" GET /" this :write
			this :@name this :write
			$crlf COUNT this :write
			this :flush_file
		;   


		: _do_get ( --0|$)
			['] _(do_get) CATCH
		;

		m:  ( addr len -- len)
			%%done_get @ not IF
				_do_get ABORT" server failed to take command"
				TRUE %%done_get !
			THEN
			_read_tcp
		; overrides :read



		m:  { ( addr len -- len) }{
				variable %len 
				variable %addr }
			%%done_get @ not IF
				_do_get ABORT" server failed to take command"
				TRUE %%done_get !
			THEN


			DUP %len !
			OVER %addr !

			\ addr len(--
			_read_terminal_stream
			\ addr1 len1(--
			NIP %addr @ SWAP
			\ addr len1(--
			%len @ SWAP - 
			\ addr len3(--
			this :termination>code
			\ len4 flag(--
		; overrides :read_line

		m: ( indent --)
			CR DUP SPACES ." html | " ." Object: " this .h  
			DROP send
		; overrides :print


&drivers
target_definitions

end_class html

target_previous_definitions
target_previous
./version081/tcp/icmp_demux.html0100777000000000000000000007026407300314371015454 0ustar rootroot COLDFORTH KERNEL

Internet Control Message Protocol

license
RFC792 Original
RFC1122 Updated
RFC896 ICMP source quench
RFC1016 More recent source quench
RFC950 Subnet mask
RFC956 Clock
RFC957 Clock
RFC1305 Clock
RFC1812 Router requirments

How ICMP behaves has varied with time, and it would be safe to say the situation is a mess.

This bit of code deals with ICMP messages received. It attempts to deal with them in an intelligent manner.

ICMP messages are generated by the rest of the stack when the appropiate situation arises. They are sent as normal ip messages, and most will be sent out on the wire and never seen here.

Unfortunatly comer predates a lot of this stuff; so you need to read the RFC and try and get some understanding of what is being attempted.

Redirect message

For your reading pleasure

RFC792.

The gateway sends a redirect message to a host in the following situation. A gateway, G1, receives an internet datagram from a host on a network to which the gateway is attached. The gateway, G1, checks its routing table and obtains the address of the next gateway, G2, on the route to the datagram's internet destination network, X. If G2 and the host identified by the internet source address of the datagram are on the same network, a redirect message is sent to the host. The redirect message advises the host to send its traffic for network X directly to gateway G2 as this is a shorter path to the destination. The gateway forwards the original datagram's data to its internet destination.

So getting it clear in my own mind

There are three pieces of info. The destination address in the original datagram. Thats what we are being asked to redirect. The source address of the ICMP message. Thats is who is asking us to redirect. And the destination address of the ICMP datgram gives us the interface over which the redirect came. The data field contains the address of the new gateway. In theory the gateway we sent it to and the gateway we redirect to will be on the same net. If it isn't we don't accept the change.

RFC1812
5.2.7.2 Redirect

The ICMP Redirect message is generated to inform a local host the it should use a different next hop router for a certain class of traffic.

Routers MUST NOT generate the Redirect for Network or Redirect for Network and Type of Service messages (Codes 0 and 2) specified in RFC792. Routers MUST be able to generate the Redirect for Host message (Code 1) and SHOULD be able to generate the Redirect for Type of Service and Host message (Code 3) specified in RFC792. From RFC1122 Section 3.2.2.2

A host SHOULD NOT send an ICMP Redirect message; Redirects are to be sent only by gateways.

A host receiving a Redirect message MUST update its routing information accordingly. Every host MUST be prepared to accept both Host and Network Redirects and to process them as described in Section 3.3.1.2 below.

A Redirect message SHOULD be silently discarded if the new gateway address it specifies is not on the same connected (sub-) net through which the Redirect arrived [INTRO:2, Appendix A], or if the source of the Redirect is not the current first-hop gateway for the specified destination (see Section 3.3.1).

DISCUSSION If the directly connected network is not subnetted (in the classical sense), a router can normally generate a network Redirect that applies to all hosts on a specified remote network. Using a network rather than a host Redirect may economize slightly on network traffic and on host routing table storage. However, the savings are not significant, and subnets create an ambiguity about the subnet mask to be used to interpret a network Redirect. In a CIDR environment, it is difficult to specify precisely the cases in which network Redirects can be used. Therefore, routers must send only host (or host and type of service) Redirects.

A Code 3 (Redirect for Host and Type of Service) message is generated when the packet provoking the redirect has a destination for which the path chosen by the router would depend (in part) on the TOS requested.

Conclusion If you get a net redirect it is an old router. I think however you should take note. If it is an old router it may be the best you get.

Remember redirect only deals with connected networks. And is saying hay dumbo, this other gateway is connected to the same net as I am, I am about to send the packet to that gateway, why in the hell don't you send it there instead of wasting my time? 

  
	: icmp_redirect { variable %pep -- }{
		variable %route_entry
		variable %tos
		variable %ipdata
		}
		
		\ only accept codes that have been defined when code was written
		%pep @ ep_ipdata + @  %ipdata ! 
		%ipdata @ ic_code + B@ 
		DUP ICC_LAST_DEFINED > IF
			DROP
			%pep @ kill_free_buffer 
			zero
			EXIT
		THEN
	
		\ the default is tos zero
		zero %tos !
		\ code(--
		\ if redirect was for tos then determine
		DUP ICC_TOSHRD = SWAP ICC_TOSNRD = IF
			\ extract tos from returned datagram and set tos
			%ipdata @ ic_data + _ip>ip_tos %tos !
		THEN
		\ (--
		\ get route entry. 
		\ Remember the data portion of the redirect message
		\ contains the original datagram.
		%ipdata @ ic_data + _ip_route_get %route_entry !
		\ if _ip_route_get returns 0 the route has gone.
		%route_entry @ not IF			 
			\ no can do, no route in table for destination in any form
			\ nothing to redirect.
			\ This is serious, as the default route at least should be returned.
			\ It is not for us to reason why.
			%pep @ kill_free_buffer
			EXIT
		THEN

		\ Unfortunatly the redirect doesn't come with nice things like expected metric
		\ and netmask mask. We need to extract that from the current routing record.
		\ The current routing record may be the one we used to send the packet, then
		\ again it may not be. We extract the destination address of the original datagram
		\ determine the route we would now use and then do some sanity checks. 
		\ If it looks like the redirect may improve the situation we use it.
	
		\ Make sure redirect came from gateway we currently
		\ believe we would send the datagram to. This is a timing
		\ thing. Message may be old info, we may have received a better route since the datagram
		\ in question was sent.
		%pep @ [ ep_data ip_src + ]T LITERAL + @
		%route_entry @ rt_gw + @ <> IF
			%route_entry @ route_free
			%pep @ kill_free_buffer
			EXIT
		THEN
		 
		\ stupidity check
		\ Did the data come from a interface we would have sent the original datagram on.
		\ Can happen if there are two connecting nets, or if someone is trying to get you to
		\ send the data to a different network. The latter is a serious problem.
		%pep @ ep_nif_received + @
		%route_entry @ rt_interface + @ <> IF
			%route_entry @ route_free
			%pep @ kill_free_buffer
			EXIT
		THEN

		\ route_add { variable %net
		\             variable %mask 
		\             variable %gw 
		\             variable %metric
		\             variable %tos
		\             variable %interface 
		\             variable %ttl
		\             variable %how 
		\             variable %broadcast ( -- $ ) 

		\ add the specific entry
		%ipdata @ [ ic_data ip_dst + ]T LITERAL + @   \ destination address
		ip_maskall                                    \ only use entry for this address
		%ipdata @ ic_gw + @                           \ gateway to redirect to
		%route_entry @ rt_metric + @  1-              \ the aim of the exercise
		                                              \ to reduce the metric by 1
		%tos @                                        \ tos of service offered
		%route_entry @ rt_interface + @               \ Interface to send outgoing data over
		IC_RDTTL                                      \ how long the route is to live
		RT_ICC_REDIRECT                               \ how the route was generated
		FALSE
		route_add


		%route_entry @ route_free
		%pep @ kill_free_buffer

		zero 
		EXIT
	;



protocol class

	protected
		cell% instance_variable %%icmp_in_errors
		cell% instance_variable %%IcmpInErrors
		cell% instance_variable %%IcmpInMsgs
		cell% instance_variable %%IcmpInEchos
		cell% instance_variable %%icmp_option_error		
	public
		m: ( --)
			this [parent] :construct
			
			zero %%IcmpInErrors !
			zero %%IcmpInMsgs   !
			zero %%IcmpInEchos  !
			
			IPT_ICMP   %%protocol_number !
			\ if we return $ we where not added to proto table
			\ and we should not try and remove ourselves.
			this IPT_ICMP  proto_add not %%installed !
		; overrides :construct

		\ called if the byte order has to be swaped for network 
		\ transmission. This is done in the interface just prior
		\ to transmission. On reception it is done after the protocol
		\ demux, otherwise we would have to demux twice.
		m: ( pep --) 
			DROP
			\ is required but not for coldfire
		; overrides :proto_host<>net 


		 
 
		: icmp_error  ( pep -- )
			1 %%IcmpInErrors +!
			kill_free_buffer 
		;

		\ Fix up the
		\ received datagram and send it on it's way.
		: icmp_echo_responce { variable %pep -- }{
			variable %ipdata_in
			variable %ipdata_length 
			variable %tos 
			\ variable %old_id 
			}
			%pep @ ep_error + @ IF
				%pep @ kill_free_buffer
				EXIT
			THEN

			%pep @ ep_ipdata + @ %ipdata_in !

			\ when the header is setup the data length is lost
			\ so put it aside
			%pep @ _pep>ip_data_length  %ipdata_length ! 


			%pep @ DUP setup_pep_from_pep


			this  %pep @  ep_proto_obj  + !
			\ protocol type is lost when header is constructed
			IPT_ICMP %pep @ [ ep_data ip_proto + ]T LITERAL + B!

			\ move contents of datagram down if required
			\ remember options may be the same length or shorter
			%ipdata_in @ %pep @ ep_ipdata + @ 
			<> IF
				%ipdata_in @ %pep @ ep_ipdata + @ %ipdata_length @ MOVE
			THEN

			\ add the data length to the pep
			%ipdata_length @ %pep @ add_to_ip

			\ change type to echo responce
			ICT_ECHORP %pep @ ep_ipdata + @ ic_type + B!	

			\ and send it on its way.
			%pep @ queue_ip
			restart_level
		;


		\ Fix up the
		\ received datagram and send it on it's way.
		\ COLDFORTH asks the gateway for the time.
		\ COLDFORTH can be the gateway so this has to
		\ be implemented.
		: icmp_timestamp_responce { variable %pep -- }{
			variable %ipdata_in
			variable %ipdata_length 
			variable %tos 

			ic1_length
			DUP CONSTANT _#org_timestamp 4 +
			DUP CONSTANT _#rev_timestamp 4 +
			DUP CONSTANT _#trans_timestamp 4 +
			DUP CONSTANT _#message_length
			DROP
			 
			}
			%pep @ ep_error + @ IF
				%pep @ kill_free_buffer
				EXIT
			THEN

			%pep @ ep_ipdata + @ %ipdata_in !

	
			\ when the header is setup the data length is lost
			\ so put it aside
			%pep @ _pep>ip_data_length  DUP %ipdata_length ! 

			\ if the received is not long enough we cannot send a reply
			_#message_length < IF
				%pep @ kill_free_buffer
				EXIT
			THEN

			%pep @ DUP setup_pep_from_pep

			this  %pep @  ep_proto_obj  + !

			\ protocol type is lost when header is constructed
			IPT_ICMP %pep @ [ ep_data ip_proto + ]T LITERAL + B!

			\ move contents of datagram down if required
			\ remember options may be the same length or shorter
			%ipdata_in @ %pep @ ep_ipdata + @ 
			<> IF
				%ipdata_in @ %pep @ ep_ipdata + @ %ipdata_length @ MOVE
			THEN

			\ add the data length to the pep
			%ipdata_length @ %pep @ add_to_ip

			\ change type to echo responce
			ICT_TIMERP  %pep @ ep_ipdata + @ ic_type + B!	

			\ add the required timestamps
			\ Update fields that must be done
			@standard_ms DUP 
			%pep @ ep_ipdata + @ _#rev_timestamp + ! 
			%pep @ ep_ipdata + @ _#trans_timestamp + !  

			\ and send it on its way.
			%pep @ queue_ip
			restart_level
		;



	\ table of error messages for the different codes
	\ we use named strings so the used can use the about
	\ string to initiate recovery action.
	CREATE $net_unreached    ," network unreachable"
	CREATE $dest_unreached	 ," host unreachable"
	CREATE $proto_unreached  ," protocol unreachable"
	CREATE $port_unreached   ," port unreachable"
	CREATE $frag_needed      ," require fragmentation"
	CREATE $src_route_fail   ," source route failed"
	CREATE $net_unknown      ," network unknown"
	CREATE $host_unknown     ," host unknown"
	CREATE $host_isolated    ," host isolated"
	CREATE $net_prohibited   ," network access prohibited"
	CREATE $host_prohibited  ," host access prohibited"
	CREATE $net_tos_prob     ," network type of service problems"
	CREATE $host_tos_prob     ," host type of service problems"
	CREATE $host_out_range    ," Unknown error returned by destination"

	CREATE unreached_error_strings 
		$net_unreached    t,
		$dest_unreached	  t,
		$proto_unreached  t,
		$port_unreached   t,
		$frag_needed      t,
		$src_route_fail   t,
		$net_unknown      t,
		$host_unknown     t,
		$host_isolated    t,
		$net_prohibited   t,
		$host_prohibited  t,
		$net_tos_prob     t,
		$host_tos_prob    t,
		$host_out_range   t,

	#13 CONSTANT _#max_error_code

	: icmp_dest_unreached { variable %pep }{
		variable %ipdata }
		%pep @ ep_ipdata + @ %ipdata !
		%pep @ ep_ipcount + @ ic_data -
		IPMHLEN  
		< IF
			\ not enough of the datagram was returned
			%pep @ kill_free_buffer
			EXIT
		THEN
		\ address of error string
		%ipdata @ ic_code + B@ _#max_error_code MIN CELLS
		unreached_error_strings + @
		%pep @ ep_error + !

		\ protocol that caused error.
		%ipdata @ ic_data + ip_proto + B@ 
		proto_find ?DUP IF
			\ we have the protocol
			%pep @ OVER _#demux_bucket_object + @ :proto_error
			proto_release
			EXIT
		THEN
		\ get to here and we can't find protocol that generated original
		\ packet. This is give up time.
		\ (--
		%pep @ kill_free_buffer
	;			

	\ table of error messages for the different codes
	\ we use named strings so the used can use the about
	\ string to initiate recovery action.
	CREATE $transit_timeout  ," Time exceeded in transit"
	CREATE $defrag_timeout	 ," Defrag timeout"
	CREATE $unknown_timeout  ," Unknown timeout message"

	CREATE timeout_error_strings 
		$transit_timeout t, 
		$defrag_timeout	 t, 
		$unknown_timeout t,

	
	#2 CONSTANT _#max_timeout_code

	: icmp_timeout { variable %pep }{
		variable %ipdata }
		%pep @ ep_ipdata + @ %ipdata !
		%pep @ ep_ipcount + @ ic_data -
		IPMHLEN  
		< IF
			\ not enough of the datagram was returned
			%pep @ kill_free_buffer
			EXIT
		THEN
		\ address of error string
		%ipdata @ ic_code + B@ _#max_timeout_code MIN CELLS
		timeout_error_strings + @
		%pep @ ep_error + !

		\ protocol that caused error.
		%ipdata @ ic_data + ip_proto + B@ 
		proto_find ?DUP IF
			\ we have the protocol
			%pep @ OVER _#demux_bucket_object + @ :proto_error
			proto_release
			EXIT
		THEN
		\ get to here and we can't find protocol that generated original
		\ packet. This is give up time.
		\ (--
		%pep @ kill_free_buffer
	;
RFC1700 page 69
       Codes
            0  Pointer indicates the error
            1  Missing a Required Option        [RFC1108]
            2  Bad Length

 	
	\ table of error messages for the different codes
	\ we use named strings so the used can use the about
	\ string to initiate recovery action.
	\ It is difficult to get the pointer value and it
	\ probable not worth making it available.
	CREATE $param_problem  ," Parameter problem"
	CREATE $param_missing  ," missing a required option"
	CREATE $param_bad_length   ," Bad length"
	CREATE $param_unknown  ," Unknown parameter problem code"
	
	CREATE parameter_error_strings 
		$param_problem t,
		$param_missing t,
		$param_bad_length t, 
		$param_unknown t,

	
	#3 CONSTANT _#max_parameter_code

	: icmp_parameter { variable %pep }{
		variable %ipdata }
		%pep @ ep_ipdata + @ %ipdata !
		%pep @ ep_ipcount + @ ic_data -
		IPMHLEN  
		< IF
			\ not enough of the datagram was returned
			%pep @ kill_free_buffer
			EXIT
		THEN
		\ address of error string
		%ipdata @ ic_code + B@ _#max_parameter_code MIN CELLS
		parameter_error_strings + @
		%pep @ ep_error + !

		\ protocol that caused error.
		%ipdata @ ic_data + ip_proto + B@ 
		proto_find ?DUP IF
			\ we have the protocol
			%pep @ OVER _#demux_bucket_object + @ :proto_error
			proto_release
			EXIT
		THEN
		\ get to here and we can't find protocol that generated original
		\ packet. This is give up time.
		\ (--
		%pep @ kill_free_buffer
	;

Echo

Echo reply demux. The demux is done on the message id. You have to open a echo_client to ping a machine.

The more lists the faster the demux, the more memory you use. Set as desired. 

 
	ram_variable _%echo_last_identifier
	\ we don't expect many open echo clients
	$2 CONSTANT _#echo_head_num
	ram_variable _%echo_table _#echo_head_num CELLS ram_allot

_echo_find and _echo_release will be used in the protocol object. _echo_add and _echo_close will be used in the io_common object for open and close. 

 
	: _echo_find ( identifier --addr|zero)
		_%echo_table _#echo_head_num demux_find
	;

	: _echo_add ( object identifier -- $|0 )
		_%echo_table _#echo_head_num  demux_add
	;

	: _echo_release ( addr --)
		demux_release
	;

	: _echo_remove ( identifier --)
		_%echo_table _#echo_head_num demux_remove
	;

Because each conversation has an identifier, we do not have to look at the source machine when demuxing echo responces. This speeds up the demux. 

 
	: _echo_identifier ( object -- identifier )
		_%echo_last_identifier @
		$0FFFF AND
		\ if two tasks are trying at the same time
		\ one will get in first and the other will keep
		\ going.
		BEGIN 
			2DUP _echo_add
		WHILE
			1+
			$0FFFF AND
		REPEAT
		NIP 
		\ when we store the up to port we must make sure
		\ the task with the highest used port wins.
		_lock_word
		DUP _%udp_last_port @ 2DUP - ABS $07FFF > IF
			\ wrapped around
			MIN
		ELSE
			MAX
		THEN 
		_%echo_last_identifier !
		_unlock_word
	;


	\ if your going to do it; you may as well do it properly.
	\ ping opens a echo_client; we have to take the reply
	\ and demux to the opened client. 
	ram_variable %echo_demux_cnt
	: icmp_echo_demux ( pep -- )
		1 %echo_demux_cnt +!
		DUP ep_ipdata + @ ic_id + W@
		\ pep id(--
		_echo_find DUP IF
			\ pep table(--
			\ this is a method in io_common
			TUCK _#demux_bucket_object + @ :consume_port
			_echo_release
			EXIT
		THEN
		\ pep zero(--
		\ don't send an error message the server is not interested.
		DROP
		kill_free_buffer
	;

Timestamp

timestamp reply demux. The demux is done on the message id. You have to open a icmp_timestamp object to get a remote machines timestamp

The more lists the faster the demux, the more memory you use. Set as desired. 

 
	ram_variable _%timestamp_last_identifier
	\ we don't expect many open echo clients
	$2 CONSTANT _#timestamp_head_num
	ram_variable _%timestamp_table _#timestamp_head_num CELLS ram_allot

_timestamp_find and _timestamp_release will be used in the protocol object. _timestamp_add and _timestamp_close will be used in the io_common object for open and close. 

 
	: _timestamp_find ( identifier --addr|zero)
		_%timestamp_table _#timestamp_head_num demux_find
	;

	: _timestamp_add ( object identifier -- $|0 )
		_%timestamp_table _#timestamp_head_num  demux_add
	;

	: _timestamp_release ( addr --)
		demux_release
	;

	: _timestamp_remove ( identifier --)
		_%timestamp_table _#timestamp_head_num demux_remove
	;

Because each conversation has an identifier, we do not have to look at the source machine when demuxing timestamp responces. This speeds up the demux. 

 
	: _timestamp_identifier ( object -- identifier )
		_%timestamp_last_identifier @
		$0FFFF AND
		\ if two tasks are trying at the same time
		\ one will get in first and the other will keep
		\ going.
		BEGIN 
			2DUP _timestamp_add
		WHILE
			1+
			$0FFFF AND
		REPEAT
		NIP 
		\ when we store the up to port we must make sure
		\ the task with the highest used port wins.
		_lock_word
		DUP _%udp_last_port @ 2DUP - ABS $07FFF > IF
			\ wrapped around
			MIN
		ELSE
			MAX
		THEN 
		_%timestamp_last_identifier !
		_unlock_word
	;


	\ if your going to do it; you may as well do it properly.
	\ timestamp opens a icmp_timestamp; we have to take the reply
	\ and demux to the opened client. 
	ram_variable %timestamp_demux_cnt
	: icmp_timestamp_demux ( pep -- )
		1 %timestamp_demux_cnt +!
		DUP ep_ipdata + @ ic_id + W@
		\ pep id(--
		_timestamp_find DUP IF
			\ pep table(--
			\ this is a method in io_common
			TUCK _#demux_bucket_object + @ :consume_port
			_timestamp_release
			EXIT
		THEN
		\ pep zero(--
		\ don't send an error message the server is not interested.
		DROP
		kill_free_buffer
	;
RFC1700 page 67 
Type    Name                                    Reference
----    -------------------------               ---------
  0     Echo Reply                               [RFC792]
  1     Unassigned                                  [JBP]
  2     Unassigned                                  [JBP]
  3     Destination Unreachable                  [RFC792]
  4     Source Quench                            [RFC792]
  5     Redirect                                 [RFC792]
  6     Alternate Host Address                      [JBP]
  7     Unassigned                                  [JBP]
  8     Echo                                     [RFC792]
  9     Router Advertisement                    [RFC1256]
 10     Router Selection                        [RFC1256]
 11     Time Exceeded                            [RFC792]
 12     Parameter Problem                        [RFC792]
 13     Timestamp                                [RFC792]
 14     Timestamp Reply                          [RFC792]
 15     Information Request                      [RFC792]
 16     Information Reply                        [RFC792]
 17     Address Mask Request                     [RFC950]
 18     Address Mask Reply                       [RFC950]
 19     Reserved (for Security)                    [Solo]
 20-29  Reserved (for Robustness Experiment)        [ZSu]
 30     Traceroute                              [RFC1393]
 31     Datagram Conversion Error               [RFC1475]
 32     Mobile Host Redirect              [David Johnson]
 33     IPv6 Where-Are-You                 [Bill Simpson]
 34     IPv6 I-Am-Here                     [Bill Simpson]
 35     Mobile Registration Request        [Bill Simpson]
 36     Mobile Registration Reply          [Bill Simpson]
 37-255 Reserved                                    [JBP]

 
		\ There has to be an entry in this table for every ICMP error type up to mask reply.
		CREATE _ict_type_vectors
			' icmp_echo_demux      t, \ 0 ICT_ECHORP	\ Echo reply
			' icmp_error    t, \ 1 spare
			' icmp_error    t, \ 2 spare
			' icmp_dest_unreached  t, ( icmp_destur )   \ 3 ICT_DESTUR	   \ Destination unreachable
			' icmp_error    t, ( icmp_srcq   )   \ 4 ICT_SRCQ	   \ Source quench
			' icmp_redirect t, \ 5 ICT_REDIRECT  \ Redirect message type
			' icmp_error    t, \ 6 spare
			' icmp_error    t, \ 7 spare
			' icmp_echo_responce   t, \ 8 ICT_ECHORQ    \ Echo request
			' icmp_error    t, \ 9 spare
			' icmp_error    t, \ 10
			' icmp_timeout  t, ( icmp_timex  )   \ 11 ICT_TIMEX    \ Time exceeded
			' icmp_parameter  t, ( icmp_paramp )   \ 12 ICT_PARAMP   \ Parameter Problem
			' icmp_timestamp_responce t,  ( icmp_timerq )   \ 13 ICT_TIMERQ   \ Timestamp request
			' icmp_timestamp_demux      t, ( icmp_timerp )   \ 14 ICT_TIMERP   \ Timestamp reply
			\ rfc1122
			\ says Information request/reply is not the way to go.
			' icmp_error    t, \ 15 ICT_INFORQ   \ Information request
			' icmp_error    t, \ 16 ICT_INFORP   \ Information reply

			' icmp_error    t, ( icmp_maskrq )   \ 17 ICT_MASKRQ   \ Mask request
			' icmp_error    t, ( icmp_maskrp )   \ 18 ICT_MASKRP   \ Mask reply
			' icmp_error    t, \ 19 ICT_MAX_TYPE, must always point to error

		ICT_MAX_TYPE #20 ??<  \ make sure table is long enough

		\ used by the proto task to get rid of the packet.
		m: { ( pep -- ) }{
			variable %ipdata }
			\ ### temp
			DUP ep_ipdata + @ %ipdata !
			%ipdata @ OVER ep_ipcount + @ cksum IF
				1 %%IcmpInErrors +!
				kill_free_buffer
				EXIT
			THEN
			1 %%IcmpInMsgs +!
			%ipdata @ ic_type + B@  
			zero MAX ICT_MAX_TYPE MIN CELLS
			\ pep offset(--
			_ict_type_vectors + @execute
		; overrides :proto_demux

		\ this will be used by negative responces to echo requests,
		\ mask requests, and timestamp requests.
		m: { variable %pep -- }{
			variable %ipdata 
			variable %returned_ipdata }
			%pep @ ep_ipdata + @ %ipdata !
			%ipdata @ ic_data + _ip>ip_hlen %ipdata @ ic_data + OVER +
			%returned_ipdata !
			\ header_length_returned_datagram(--
			%pep @ ep_ipcount + @ ic_data - SWAP - ic_data < IF  \ >
				\ (--
				\ didn't return icmp header
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ lets deal with the echo first
			%returned_ipdata @ ic_type + B@ ICT_ECHORQ = IF
				%returned_ipdata @ ic_id + W@ _echo_find ?DUP IF
					\ table(--
					\ this is a method in io_common
					%pep @ OVER _#demux_bucket_object + @ :consume_port
					_echo_release
					EXIT
				THEN
			THEN
			\ ##### still have to do mask request.
			\ and timestamp request.
			\ get here and there is nowhere for error to go
			\ give up
			%pep @ kill_free_buffer
		; overrides :proto_error


		\ interface calls this to checksum the protocol; some protocols
		\ need info gained in the ip layer to generate correct checksum
		\ icmp isn't one of them; but we use a consistant path.
		m: { ( pep --) }{
			variable %ipdata }
			DUP ep_ipdata + @ %ipdata !
			zero %ipdata @ ic_cksum + W!
			%ipdata @ SWAP ep_ipcount + @ cksum
			%ipdata @ ic_cksum + W!
		; overrides :proto_checksum	

		\ tell the world about ourselves
		m: ( offset --)
			CR DUP SPACES ." icmp_protocol | " ." Object: " this .h 
			              ." protocol_number: " %%protocol_number @ .h
			              ." installed: " %%installed @ IF
                              ." Yes"
			              ELSE
			                  ." No"
			              THEN
			DROP
		; overrides :print

end_class icmp_protocol
./version081/tcp/icmp_echo.html0100777000000000000000000002104307300314371015237 0ustar rootroot COLDFORTH KERNEL

the I/O classes for icmp_echo

license
RFC792 Original
RFC1122 Updated
RFC896 ICMP source quench
RFC1016 More recent source quench
RFC950 Subnet mask
RFC956 Clock
RFC957 Clock
RFC1305 Clock
RFC1812 Router requirments

A user opens a icmp_echo to use the icmp echo protocol. The first two bytes written are the sequence number. They may be very relevent to the ping word, but they are of no interest to the system. If you use it as a two byte ascii number you get 99 id's more than enough. 

 
io_protocol_common class

		cell% instance_variable %%identifier

				
		\ errors/stats
		cell% instance_variable %%read_errors
		cell% instance_variable %%bad_echo_structure

		m: ( parent--)
			this [parent] :construct
			zero %%bad_echo_structure !
			zero %%read_errors !
		; overrides :construct

		\ while the port is open we can recieve more peps 
		\ this has to stop before we can proceed.
		: _wait_for_echo_close ( identifier --)
			BEGIN
				DUP _echo_find DUP not IF
					\ port addr(--
					2DROP
					EXIT
				THEN
				\ port addr(--
				 _#demux_bucket_object + @ this <> IF
					\ someone else has the port now
					\ port(--
					DROP
					EXIT
				THEN
				\ port(--
				xpause
			AGAIN
		;

		m: ( --)
			\ Remove ourselves from the icmp_echo_demux table.
			\ We cannot proceed until this is done. If there is a bug 
			\ in the code ( more finds than releases,) we will wait here
			\ forever.
			%%identifier @ _echo_remove
			%%identifier @ _wait_for_echo_close
			this [parent] :destruct
		; overrides :destruct

		\ string can be /destination_machine
		\               or nothing
		m: ( addr n mode -- instance )
			%%mode !
			\ /machine
			[CHAR] / remove_leading
			\ addr_machine count_machine(--
			DUP IF \ machine specified
				Sresolve_address %%remote_machine !
			ELSE
				2DROP
			THEN
			\ ask the os for a identifier
			\ as soon as we do this we can start receiving 
			\ datagrams destined to the allocated port.
			\ As no one knows about us it is not likely, but it
			\ is possible.
			\ getting the identifer adds it to the demux table
			this _echo_identifier %%identifier !
			this
		; overrides :Sopen


		\ protocol says there is a two byte sequence number after
		\ identifer. As far as we are concerned it is part of the
		\ users data area. How the user uses it is his problem. We
		\ are defintily not going to get involved in creating and
		\ tranfering a sequence number.
		: setup_echo { ( identifier ) variable %pep -- }

			_%icmp_object @ 
			%pep @ ep_proto_obj + !

			IPT_ICMP %pep @ [ ep_data ip_proto + ]T LITERAL + B!
					
			%pep @ ep_ipdata + @ ic_seq ERASE

			ICT_ECHORQ	  %pep @ ep_ipdata + @ ic_type + B!
			\ identifier(--
			 %pep @ ep_ipdata + @ ic_id + W!

			ic_seq %pep @ add_to_ip
		;

		m: { variable %pep -- }
			%%local_machine @
			%%remote_machine @ 
			zero
			%pep @ setup_ip
			\ priority can be set as a object variable.
			\ If you ping a COLDFORTH system it has some meaning.
			\ The rest of the internet expects the priority to be zero
			\ in all ICMP messages.
			%%priority @  5 RSHIFT 
			%pep @ [ ep_data ip_tos + ]T LITERAL + B! 
			\ ------------------------------------------
			\ this word sets up a header with no options
			\ if you want options do it yourself.
			\ ------------------------------------------
			\ setup the echo header; this does not include the sequence.
			%%identifier @
			%pep @
			setup_echo

		; overrides :setup_protocol


		\ the icmp echo message shows a little logic there is not an 
		\ additional count
		: _add_to_echo ( n pep)
			add_to_ip
		;

An application should call :setup_protocol or :setup_protocol_from_pep

to initialise the pep header. It should then alter header if desired. 

 
		\ as the echo server is implemented in icmp_protocol; there is no
		\ need for this method.
		m: ( variable %pep_in variable %pep_out -- )
			TRUE ABORT" :setup_protocol_from_pep not implemenented."
		; overrides :setup_protocol_from_pep 


		: _pep>echo_data ( pep -- pep addr n 0 | $)
			DUP ep_ipdata + @
			\ pep addr(--
			OVER ep_ipcount + @ 
			\ pep addr len(--
			ic_seq -
			SWAP 
			ic_seq +
			SWAP
			zero
		;

		\ The big qestion; should We close on an abort or leave it
		\ to the user. The rule is if you take one of these words you can 
		\ convert it into a ior type result with a simple catch. That means
		\ you don't close
		m:  { ( --pep addr n ) }
				%%pep_queue xawait
				%%pep_queue dequeue
				\ pep(--
				DUP ep_error + @ not IF
					_pep>echo_data ?DUP IF
						1 %%bad_echo_structure +!
						$ABORT
					THEN
					\ pep addr n(--
					EXIT
				THEN
				1 %%read_errors +!
				DUP ep_error + @
				SWAP kill_free_buffer
				$ABORT
		; overrides :read_protocol



		\ the read operation treats each datagram
		\ as a record.
		m:  ( addr len -- len)
			%%active_pep @ not IF
				\ do if for the side effects not the 
				\ stack items
				this :read_protocol 
				%%active_count !
				%%active_pointer !
				%%active_pep !
			THEN
			\ addr len(--
			_read_from_active_pep
			\ len(--
		; overrides :read

		\ write the data pointed to by addr and n to the pep and queue.
		\ we have to write something as the first two bytes are
		\ the sequene number
		CREATE _$default ," 00 hi"
		m: { ( addr n --) variable %pep }
			DUP not IF
				2DROP
				_$default
				COUNT
			THEN
			TUCK
			\ n addr n (--
			%pep @ ep_ipdata + @ ic_seq + SWAP MOVE
			\ n(--
			\ have to now fix up ep_len and ip_length
			%pep @ _add_to_echo
			%pep @ queue_ip
		; overrides :write_protocol

		\ returns true if data
		m: ( --flag)
			%%active_pep  @ 0= 
			%%pep_queue queue_empty? AND not
		; overrides :key?

		m: ( indent --)
			CR DUP SPACES ." icmp_echo | " ." Object: " this .h 
			CR DUP SPACES ." remote machine: " %%remote_machine @ .h 
			CR DUP SPACES ." local machine      : " %%local_machine @ .h
			CR DUP SPACES ." priority           : " %%priority @ .h
			              ." input_pep_queue : " %%pep_queue .h
			CR DUP SPACES ." datagram receives  : " %%datagrams_received @ .h
			              ." discards        : " %%datagram_discards @ .h
			\ indent(--
			CR DUP SPACES ." type buffer        : " %%type_buffer> @ .h
			              ." type count      : " %%type_buffer_count @ .h
			DROP
			send
		; overrides :print

target_also

&drivers
target_definitions

end_class icmp_echo

target_previous_definitions
target_previous


	: ping { ( --) }{
		variable %sent_messages
		variable %received_messages 
		#8 CONSTANT #colume_size
		}
		0 %sent_messages !
		0 %received_messages !
		$" icmp_echo/" BL WORD #$buffer get_buffer buffer #$buffer $+ 
		\ temp
		buffer zero $open kill_buffer
		CR
		BEGIN
			\ object(--
			DUP :key? IF
				CR
				\ object(--
				DUP ['] _receive_ping CATCH ?DUP IF
					CR 
					." sent messages: " %sent_messages @ .
					." recieved messages: " %received_messages @ . 
					NIP SWAP close
					$ABORT
				THEN
				1 %received_messages +!
			ELSE
				1 %sent_messages +!
				\ object(--
				DUP ['] _ping_message CATCH ?DUP IF
					CR 
					." sent messages: " %sent_messages @ .
					." recieved messages: " %received_messages @ . 
					NIP SWAP close
					$ABORT
				THEN
				IF 
					1 %received_messages +!
				THEN
			THEN
			character# #colume_size + character_max @ < not IF CR THEN 
			\ don't want internet to get upset with ping rate.
			#1sec xtest xwait
		AGAIN
	;
./version081/tcp/icmp_h.html0100777000000000000000000001123707300314371014554 0ustar rootroot COLDFORTH KERNEL

Internet Control Message Protocol Constants and Packet Format

license
RFC792 Original
RFC1122 Updated
RFC896 ICMP source quench
RFC1016 More recent source quench
RFC950 Subnet mask
RFC956 Clock
RFC957 Clock
RFC1305 Clock

ic_type field

 
	0   CONSTANT ICT_ECHORP	  \ Echo reply
	3   CONSTANT ICT_DESTUR	  \ Destination unreachable
	4   CONSTANT ICT_SRCQ	  \ Source quench
	5   CONSTANT ICT_REDIRECT \ Redirect message type
	8   CONSTANT ICT_ECHORQ	  \ Echo request
	#11 CONSTANT ICT_TIMEX	  \ Time exceeded
	#12 CONSTANT ICT_PARAMP   \ Parameter Problem
	#13 CONSTANT ICT_TIMERQ	  \ Timestamp request
	#14 CONSTANT ICT_TIMERP	  \ Timestamp reply
	#15 CONSTANT ICT_INFORQ   \ Information request
	#16 CONSTANT ICT_INFORP	  \ Information reply
	#17 CONSTANT ICT_MASKRQ   \ Mask request
	#18 CONSTANT ICT_MASKRP   \ Mask reply
	#19 CONSTANT ICT_MAX_TYPE \ Error

ic_code field

 
	0   CONSTANT _#icc_net_unreached    \ dest unreachable, net unreachable
	1   CONSTANT _#icc_dest_unreached	\ dest unreachable, host unreachable
	2   CONSTANT _#icc_proto_unreached  \ dest unreachable, proto unreachable
	3   CONSTANT _#icc_port_unreached   \ dest unreachable, port unreachable
	4   CONSTANT _#icc_frag_needed      \ dest unr, frag needed & don't frag
	5   CONSTANT _#icc_src_route_fail   \ dest unreachable, src route failed
	6   CONSTANT _#icc_net_unknown 
	7   CONSTANT _#icc_host_unknown
	8   CONSTANT _#icc_scr_host_isolated
	9   CONSTANT _#icc_net_prohibited
	$0A CONSTANT _#icc_host_prohibited
	$0B CONSTANT _#icc_net_tos_prob
	$0C CONSTANT _#icc_host_tos_prob


 	0   CONSTANT ICC_NETRD    \ redirect: net
	1   CONSTANT ICC_HOSTRD	  \ redirect: host
	2   CONSTANT ICC_TOSNRD    \ redirect: type of service, net
	3   CONSTANT ICC_TOSHRD    \ redirect: type of service, host
	3   CONSTANT ICC_LAST_DEFINED

	0   CONSTANT ICC_TIMEX	  \ time exceeded, ttl
	1   CONSTANT ICC_FTIMEX	  \ time exceeded, frag

	8   CONSTANT IC_HLEN      \ octets
	3   CONSTANT IC_PADLEN    \ pad length (octets)	

	#1sec #300 * CONSTANT IC_RDTTL	  \  ttl for redirect routes

ICMP packet format (following the IP header)

 
	\ header	
	zero
	DUP CONSTANT ic_type  1+    \ type of message (ICT_* above)
	DUP CONSTANT ic_code  1+    \ code (ICC_* above)
	DUP CONSTANT ic_cksum 2+    \ checksum of ICMP header+data
		CONSTANT ic_length 

	\ for echo and timestamp
	ic_length
	DUP CONSTANT ic_id   2+    \ for echo type, a message id
	DUP CONSTANT ic_seq  2+    \ for echo type, a seq. number
		CONSTANT ic1_length

	ic_length
	DUP CONSTANT ic_gw  IP_ALEN +	\ for redirect, gateway	
		CONSTANT ic2_length

	ic_length
	DUP CONSTANT ic_ptr 1+          \ pointer, for ICT_PARAMP
	DUP CONSTANT ic_pad IC_PADLEN + \
		CONSTANT ic3_length

	\ destination unreachable
	ic_length
	DUP CONSTANT ic_mbz CELL+    \  must be zero         
	DUP CONSTANT ic4_length
	    CONSTANT ic_data          \ data area of ICMP message

As a header can be $3C bytes long $40 bytes of original datgrame was never enough, see RFC792 page 5

RFC1122 Section 3.2.2 updates the requirement with. "Every ICMP error message includes the Internet header and at least the first 8 data octets of the datagram that triggered the error; more than 8 octets MAY be sent; this header and data MUST be unchanged from the received datagram". 

 
	$80 CONSTANT  _#error_header_return_length

	ic1_length ic2_length ??= 
	ic1_length ic3_length ??=
	ic1_length ic4_length ??=


	ram_variable _%icmp_object
./version081/tcp/interface_common.html0100777000000000000000000004514407300314371016631 0ustar rootroot COLDFORTH KERNEL

Fragmentation constants

license
RFC791 IP specification
 
	#06       CONSTANT NI_MAXHWA     \  max size of any hardware address
	#30       CONSTANT NI_INQSZ      \ interface input queue size
	#30       CONSTANT NETNLEN       \ length of network name


	0x01      CONSTANT NIS_UP
	0x02      CONSTANT NIS_DOWN
	0x03      CONSTANT NIS_TESTING

Used to checksum the header, and the ICMP message. The length is in bytes. The byte order of the machine doing the calculation is not important as the data read will use the machines byte order. And the checksum write will use the machines byte order. This is why the calculated checksum is stored without changing it to network byte order. However before the checksum is calculated the header has to be saved in network order, if you want the calculated checksum to be in network order. 

 
	: cksum { variable %buffer variable %length ( --checksum) }
		zero
		%buffer @ %length @ + %buffer @ DO
			I W@ +
		2 +LOOP
		DUP $10 RSHIFT SWAP $0FFFF AND +
		DUP $10 RSHIFT + 
		-1 XOR
		$0FFFF AND
	;

When the local interface object is created the object adddress is placed here. It is used by :broadcast to redirect messages to the local interface 

 


linked_object class

	ram_variable %interface_objects 

	zero bytes%       instance_variable %%interface_common_start
	NETNLEN bytes%    instance_variable %%ni_name      \ domain name of interface
	cell%             instance_variable %%ni_state     \ interface state se NIS_ above
	cell%             instance_variable %%ni_ip        \ IP address for this interface
	cell%             instance_variable %%ni_mask      \ IP subnet mask for interface
	cell%             instance_variable %%ni_mtu       \ max transfer unit (octet)
	NI_MAXHWA bytes%  instance_variable %%ni_hwa       \ hardware address of interface
	NI_MAXHWA bytes%  instance_variable %%ni_hwb       \ hardware broadcast address
	cell%             instance_variable %%authoritative_subnet  \ don't give subnet address unless set


	\ general errors
	cell%             instance_variable %%ip_fragment_discards
	cell%             instance_variable %%ip_checksum_errors
	cell%             instance_variable %%ip_version_error
	cell%             instance_variable %%ip_header_length_error

	cell%             instance_variable %%nis_not_up_discard
	cell%             instance_variable %%consume_interface_not_defined
	cell%             instance_variable %%write_pep_not_defined
	\ fragmentation can be exploited in several ways. These counts
	\ will increase if someone is playing bad.
	cell%             instance_variable %%ip_fragment_stupidity0
	cell%             instance_variable %%ip_fragment_stupidity1
	cell%             instance_variable %%ip_fragment_stupidity2
	cell%             instance_variable %%ip_fragment_stupidity3

	cell%             instance_variable %%proto_queue_discards
	zero bytes%       instance_variable %%interface_common_end

	\ whats going on
	cell%             instance_variable %%ip_frag_create
.( after instance variables)
	m: ( --)
		this [parent] :construct
		%%interface_common_start %%interface_common_end %%interface_common_start - ERASE 
	; overrides :construct

		
	m: ( --)
		this [parent] :destruct
	; overrides :destruct

	m: ( --addr)
		%interface_objects
	; overrides :list_head


	: is_broadcast? ( addr --flag)
		\ all 0 is a broadcast
		DUP 0= IF
			DROP TRUE EXIT
		THEN
		\ all 1 is a broadcast
		DUP -1 = IF
			DROP TRUE EXIT
		THEN
		DUP %%ni_mask @  OR -1 = IF
			DROP TRUE EXIT
		THEN
		DROP	 
		FALSE
	;

Packet Movement

:write_pep
  • harware address is resolved
  • if fragmentation is required it has been done
  • header has been put into network order if required
  • header has been checksummed if required
  • write_pep has no idea what the payload is

Basically all we have left is, send the packet

Whatever happens :write_pep must consume the buffer. 

 
	m: ( pep --)
		kill_free_buffer
		1 %%write_pep_not_defined +!
	; method :write_pep
:write_ip
  • harware address is resolved
  • if fragmentation is required it has been done
We still have to.
  • Convert header into network order
  • Checksum ip header

If sending the packet agross the back plane or internally nothing has to be done at this stage.

Whatever hapeens :write_ip must consume the buffer. 

  
	m: ( pep --)
		this :write_pep
	; method :write_ip

Fragment creation

ip fragmentation header copy

Copy the header. All the header is copied into the first fragment. Fragments thereafter only have copied options copied. 

 

	\ Some options have to be copied some don't
	: _ip_fragment_header { variable %pep_from variable %pep_to  variable %offset -- }{
		variable %max_addr     \ max addr
		variable %otype        \ option type
		variable %olen         \ option length
		}
		\ if offset is zero it is the first header, move the lot
		%offset @ 0 = IF
			%pep_from @ %pep_to @ 
			ep_data %pep_from @ _pep>ip_hlen + MOVE
			EXIT
		THEN

		\ move the fixed part
		%pep_from @ %pep_to @ [ ep_data ip_options + ]T LITERAL  MOVE

		\ maximum offset that can be moved is the whole header received
		%pep_from @ DUP _pep>ip_hlen ep_data + + %max_addr !
		\ start of to from options is from where we copied too
		[ ep_data ip_options + ]T LITERAL %pep_from @ +
		[ ep_data ip_options + ]T LITERAL %pep_to @ +
		\ from_addr to_addr<--
		BEGIN
			OVER %max_addr @ U<  \ >
		WHILE
			OVER + B@ %otype !
			OVER 1+ B@ %olen !
			%otype @ IPO_COPY AND IF
				\ the option length includes the byte and the length byte in it's count
				2DUP  %olen @ MOVE
				\ update the to
				%olen @ +
			ELSE
			%otype @ IPO_NOP = IF
				%otype @ OVER B!
				1 %olen !
				1+
			ELSE %otype @ IPO_EOOP = IF
				%otype @ OVER B!
				1 %olen !
				1+
				\ terminate copy
				SWAP DROP %max_addr @ SWAP
			THEN THEN THEN
			\ update the  fron address
			SWAP
			%olen @ +
			SWAP
		REPEAT
		\ from_addr to_addr<--
		NIP
		\ to_addr<--
		\ pad to multiple of 4
		BEGIN 
			DUP 3 AND
		WHILE
			IPO_NOP OVER B!
			1+
		REPEAT
		ep_data %pep_to @ + -
		\ h_length<--
		2 RSHIFT \ convert to long words
		\ update the hlen to the new value
		%pep_to @ [ ep_data ip_verlen + ]T LITERAL + B@ $F0 AND 
		OR %pep_to @ [ ep_data ip_verlen + ]T LITERAL + B!
	;
_ip_fragment_send

Copy a fragment out of the incoming packet and put on the wire.

This code should not return %pep, it is only dealing with a fraction of the job. 

 

	: _ip_fragment_send { 
				variable %last 
	            variable %pep
	            variable %offset
	            variable %send_data_length
	            variable %offset_fragment -- ( $ ) }{
	            variable %new_pep
	            }
		%pep @ _pep>ip_hlen ep_data + %send_data_length @ + ['] get_free_buffer CATCH
		?DUP IF
			\ length $<--
			NIP
			EXIT
		THEN
		\ new_buffer<--
		%new_pep !

		\ copy options etc from inital header.
		\ if %offset_fragment is zero all options get copied, if not some.
		%pep @ %new_pep @ %offset_fragment @  _ip_fragment_header
		\ set fragment offset
		%last @ IF
			\ have to use MF value from initial header
			%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ 
			IP_MF AND 
			%offset_fragment @ 3 RSHIFT OR 
			%new_pep @ [ ep_data ip_fragoff + ]T LITERAL + W!
		ELSE
			\ not the last so we have to set the more fragment bit
			%offset_fragment @ 3 RSHIFT
			IP_MF OR 
			%new_pep @ [ ep_data ip_fragoff + ]T LITERAL + W!
		THEN
		
		\ The header length of the new datagram can be different to the old
		\ not all options need to be copied
		%new_pep @ _pep>ip_hlen %send_data_length @ + 
		DUP %new_pep @ [ ep_data ip_len + ]T LITERAL + W!
		\ add in ep_data length and we have the ep_len, seems like a good 
		\ time to set it
		ep_data + %new_pep @ ep_len + !

		\ better add the data
		%pep @ DUP [ ep_data ]T LITERAL +
		SWAP _pep>ip_hlen + %offset @ +
		\ from <--
		%new_pep @ DUP  [ ep_data ]T LITERAL +
		SWAP _pep>ip_hlen + %send_data_length @ MOVE

		\ :write_ip looks after converting header to network order ( if required)
		\ and calculating header checksum ( if required)
		%new_pep @ this :write_ip
		zero
		\ $<--
	;

This code is common to all interfaces, the need for fragmentation is determined by %%ni_mtu. The local interface does not use this code, the :consume_interface method in the local interface puts fragments back together and sends them onto the protocol task. remember the routing routine calls :consume_interface to get rid of the datagram after it has routed it. The fact that the local interface takes it and delivers it, while remote interfaces take it break it up and send it on the wire is of no interest to the routing routine.

At this stage

  • the packet is as long as it was when received.
  • the ip header is still in host byte order .
  • the ip checksum is not calculated.
  • The protocol checksum has not been calculated
  • the ttl has not been decremented.
  • We have the source address.
  • The hardware address has been determined.
 
	ram_variable %decrement_ttl
	ram_variable %initial_ttl 
	CREATE $too_old ," packet ttl expired"
	\ put a ip datagram on the wire breaking it into fragments if required.
	: ip>wire { variable %pep -- ( $ ) }{
			variable %max_data
			variable %send_data_len
			variable %to_send
			variable %offset
			variable %offset_in_datagram }
		
		\ decrement the time to live here; it makes no sence to do it after
		\ fragmentation as we want all fragments to have equal change of 
		\ getting to destination. The ttl is hops or seconds. We recorded the
		\ time we placed tha packet in the ip_queue. We are now taking it out.
		\ In this sytem the chance of a packet remaining in the system for more
		\ than a second is about zero; but it takes little effort to 
		\ do it properly.
		%pep @ ep_xclock+ + @ xclock- @ + #1sec / -1 MIN
		DUP %decrement_ttl !
		%pep @  [ ep_data ip_ttl + ]T LITERAL + B@
		DUP %initial_ttl !
		+ DUP 0< IF \ >
			\ the packet has lived too long; time to zap it
			DROP
			%pep @ kill_free_buffer
			$too_old
			EXIT
		ELSE
			%pep @ [ ep_data ip_ttl + ]T LITERAL + B!
		THEN 				
		%pep @ _pep>ip_plen %%ni_mtu @ 
		> not IF
			\ datagram can go without fragmentation
			%pep @ this :write_ip
			zero
			EXIT
		THEN
		\ there is a flag to say don't fragment, if
		\ set well we are in deep shit
		%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ IP_DF AND IF
			\ make sure icmp consumes packet
			\ ##### 
			\ ICT_DESTUR ICC_FNADF %pep @ [ ep_data ip_scr + ]T LITERAL + @ %pep @ icmp
			%pep @ kill_free_buffer
			EXIT
		THEN
		\ offset into current packet
		0 %offset !
		\ fragment offset, remember we may be fragmenting a fragment
		\ fragment offset is in the low bits LSHIFT to get them out, RSHIFT to put them in
		%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ IP_FRAGOFF AND 3 LSHIFT %offset_in_datagram !


		\ For discussion on fragmentaton see
		\ RFC1812 Section 4.2.2.7
		\ I think minimum_size, minimum_fragments looks like the best option. 
		\ Best chance of not having to fragment again and gives minimum number of fragments.
		\
		\ This code may still generate a short fragment at the end, but at least one fragment
		\ will have had to be as big as the size selected.

		\ maximum fragment_units that will fit in a fragment.
		\ The remainder has to be droped as can't be used because fragment offset can only
		\ be set in fragment units.
		%%ni_mtu @ %pep @ _pep>ip_hlen - DUP %max_data ! 
		8 /MOD \ remainder f_units<--
		\ ep_ipcount is only set if datagram is consumed locally
		\ This code has to deal with network packets as well so
		\  we have to use _pep>ip_data_length
		%pep @ _pep>ip_data_length DUP %to_send !
		\ rem f_units data_size<--
		\ this allows for the remainder that can fit in last fragment
		\ because the mtu size may not be a fragment multiple. And allows
		\ for the extra fragment unit that may be required because the data_size
		\ may not be a multiple of fragment units.
		7 + ROT -
		3 RSHIFT \ max_f_units f_units_needed<--
		DUP ROT  \ f_unit_needed f_unit_needed max_f_units<--
		/MOD     \ f_units_needed rem quot<--
		SWAP IF
			\ a remainder of fragment unit need a part packet
			1+ \ send one more packet
			\ number of fragment units in packet
			/MOD SWAP IF  
				\ if we use quotent fragment units we will have a remainder, not good.
				\ add one more f_unit per packet to allow for remainder of last division
				\ the additional fragment will definitly fit as one whole packet has been
				\ added. Adding 1 will definitly see all fragment_units sent.
				1+
			THEN
		ELSE
			\ f units will fill up packets with no remainder
			/
		THEN
		3 LSHIFT 
		%send_data_len !
		BEGIN
			\ <--
			\ true if last
			%to_send @ %max_data @ > not
			%pep @
			%offset @
			jump IF
				\ last send what is remaining
				%to_send @ 
			ELSE
				\ not last fragment, send what we concluded was correct
				\ fragment size.
				%send_data_len @
			THEN
			%offset_in_datagram @

			OVER %offset +!
			OVER %offset_in_datagram +!
			OVER NEGATE %to_send +!
			_ip_fragment_send 
			?DUP IF
				\ $ <--
				\ failed to send a fragment
				\ absolutly no use continuing
				1 %%ip_fragment_discards +!
				%pep @ kill_free_buffer
				EXIT
			THEN
			1 %%ip_frag_create +!
			%to_send @ not
		UNTIL
		\ finished with this one, all broken up
		%pep @ 	
		kill_free_buffer
		zero

	;
consume_interface

This word consumes the ip packet supplied by the routed task.

Whatever happens this word must consume the packet. If must not wait to queue a packet. If the interface can't take it drop it. 

 
	m: { variable %pep  -- }
		\ just to remind people this is were this test is done	
		%%ni_state @ NIS_UP <> IF
			%pep @ kill_free_buffer
			1 %%nis_not_up_discard +!
			EXIT
		THEN
		%pep @ kill_free_buffer
		1 %%consume_interface_not_defined +!
	; method :consume_interface

A broadcast to the local net will come in, go through the routing table and come back here. We place the packet in the wire by calling :consume_interface

A broadcast from the local net will come in, go through the routing table and come back here. We can detect this by looking at ep_nif_received, if it is equal to this then the packet should be sent to the local interface. 

 
	m: ( pep --)
		kill_free_buffer
	; method :broadcast

words to access interface local data

 
	m: ( -- netmask)
		%%ni_mask  @
	; method :@netmask

	\ #### not good enough the routing table may have to be altered.
	m: ( netmask --)
		%%ni_mask !
	; method :!netmask


	\ ##### this is not good enough; the nice address has to be altered and
	\ the routing table has to be altered.
	m: ( --ip)
		%%ni_ip !
	; method :!ip

	m: ( --mtu)
		%%ni_mtu @
	; method :@mtu

Arptime

The artimer routine calls this method from each interface. The ethernet interface is an example of one that overrides this word. 

 
	m: ( --)
	; method :arptimer

.arp runs doen the interface list and calls .arp for all; those interface tables that don't use an arp should do nothing. 

 
	m: ( --)
	; method :.arp


\ access words

\ hardware address
	m: ( -- addr )
		%%ni_hwa
	; method :hwa

	m: ( --addr)
		%%ni_hwb
	; method :hwb

	m: ( --ip)
		%%ni_ip 
	; method :ip


	: set_ip ( addr object --)
		:ip !
	;


	: set_mask ( mask object --)
		:!netmask 
	;

	m: ( offset --)
		CR DUP SPACES ." interface_common | " ." Object: " this .h 
		CR DUP SPACES
		              ." ip_address: " %%ni_ip @ .h
					  \ I encourage the use of hardware addresses that print
					  \ well in ascii. Remember the only have to be unique within the
					  \ current ethernet seqment. 803.2 never got off the ground.
		              ." hardware_address: " %%ni_hwa 6 ~TYPE
		CR DUP SPACES 
		              ." frag discard : " %%ip_fragment_discards @ .h
	                  ." checksum err : " %%ip_checksum_errors @ .h
	                  ." version err  : " %%ip_version_error @ .h
		CR DUP SPACES 
	                  ." headerln err : " %%ip_header_length_error @ .h
	                  ." nis not up   : " %%nis_not_up_discard @ .h
		              ." No interface : " %%consume_interface_not_defined @ .h
		CR DUP SPACES 
		              ." Write pep err: " %%write_pep_not_defined @ .h
		              ." frag attack0 : " %%ip_fragment_stupidity0 @ .h
		              ." frag attack1 : " %%ip_fragment_stupidity1 @ .h
		CR DUP SPACES
		              ." frag attack2 : " %%ip_fragment_stupidity2 @ .h
		              ." frag attack3 : " %%ip_fragment_stupidity3 @ .h
		              ." proto discard: " %%proto_queue_discards @ .h
		DROP
		send
	; overrides :print


	

end_class interface_common


: .arp ( --)
	%interface_objects BEGIN
		@ ?DUP
	WHILE
		DUP link>object :.arp
	REPEAT
;


: _arptimer ( --)
	%interface_objects BEGIN
		@ ?DUP
	WHILE
		DUP link>object :arptimer
		xpause
	REPEAT
;

ram_variable (localhost)

CREATE $rack ," rack"

\ The default is rack
: $localhost ( -- $)
	(localhost) @ ?DUP IF 
		EXIT 
	THEN
	$rack
;

: localhost" ( "string" --)
	(localhost) @ IF
		_lock_word
			(localhost) @ 
			0 (localhost) !
		_unlock_word
		kill_free_buffer
	THEN
	[CHAR] " PARSE  \ addr count(--
	DUP _#$_data + get_free_buffer DUP >R $make
	R> (localhost) !
;  IMMEDIATE

: .localhost  ( --)
	$localhost $type
;
./version081/tcp/interface_local.html0100777000000000000000000005770607300314371016442 0ustar rootroot COLDFORTH KERNEL

local interface

license

So others can say item is locally gnerated 

 
ram_variable %local_object

interface_common class


	m: ( --)
		%local_object @ ABORT" Define local object only one"
		this [parent] :construct
		\ loopback need to know object address for
		\ the local interface
		this %local_object !
	; overrides :construct

		
	m: ( --)
		this [parent] :destruct
	; overrides :destruct

The local interface puts fragments back together so lets start off creating that code. 

 
	\ A fragment has to be combined with other fragments from the same ip packet.
	\ We hash the values the identify the fragment select a head and search the 
	\ selected list.
	40 CONSTANT #frag_heads_number
	#frag_heads_number 1 - CELLS CONSTANT #frag_head_mask
	ram_create %fragment_heads #frag_heads_number CELLS ram_allot

The frag pointers are contained in a free buffer. There is a set of frag pointers for every fragment being reassembled. Available memory limits the number of fragments that can be reassembled and the length of the fragments. So that stupidity cannot bring us down we limit the amount of memeory that can be allocated in an attempt to get a fragment back together. You will only get close to the limit if someone is deliberatly trying to bring you down. 

 
	$80000 CONSTANT _#fragment_memory_limit
	ram_variable %fragment_memory_use

	\ will allow maximum ip packet size ( 64k) over a link
	\ that supports 128 byte data packets.
	$200 CONSTANT _#fpt_max_fp

	\ A maximum datagram plus a couple of extra packets.
	$10800 CONSTANT _#frag_max_data_length



	
	\  each fragment pointer entry is structured as follows
	zero
	DUP CONSTANT	_fp_pep>           CELL+
	DUP CONSTANT	_fp_offset         CELL+
	DUP CONSTANT    _fp_offset_next    CELL+
	    CONSTANT    _fp_length

	\ the number of pointer sets by default. This is where you
	\ start if more are required a table that can take more 
	\ is created. The number selected will fit in a $100 buffer
	\ block.
	$0C CONSTANT _#fpt_default_fp

	\ the fragment table head is structured as follows
	zero
	DUP CONSTANT   _fpt_fwd_link        CELL+
	DUP CONSTANT   _fpt_back_link       CELL+
	DUP CONSTANT   _fpt_state           CELL+
	\ follow 4 fields identify datagram
	DUP CONSTANT   _fpt_id              CELL+
	DUP CONSTANT   _fpt_src             CELL+
	DUP CONSTANT   _fpt_dst             CELL+
	DUP CONSTANT   _fpt_proto           CELL+

	DUP CONSTANT   _fpt_ttl             CELL+   \ time to live
	DUP CONSTANT   _fpt_size            CELL+   \ set when last fragment received
	DUP CONSTANT   _fpt_size_set        CELL+   \ flag to say that the size has been set
	DUP CONSTANT   _fpt_no_holes_before CELL+   \ Offset from where we start checking for holes
	DUP CONSTANT   _fpt_received_length CELL+   \ Amount of data recived against 
	                                            \ this IP, used to limit buffer space
	                                            \ allocated so silly sender doesn't
                                                \ bring us down

	DUP CONSTANT   _fpt_fp_used         CELL+   \ number of fragment pointers used
	DUP CONSTANT   _fpt_fp_available    CELL+   \ number of fragmetn pointers that will fit
	                                            \ in the table
	    CONSTANT   _fpt_length

Values stored in _fpt_state. 

 
	\ if you add to the list of state names, see _find_table 
	\ fragments are being combined
	0 CONSTANT IPFF_VALID
	\ fragments can't be combined, no need to continue.
	\ When the BOGUS state is entered the ip packets are returned to buffer
	\ system leaving only the table head,
	1 CONSTANT IPFF_BOGUS
	\ the structure is finished with, timer task is destoying it, or
	\ will destroy it. In this state the ip packets have been returned, only
	\ the table entry remains.
	2 CONSTANT IPFF_FREE

	\ the length of time we will keep trying to put fragments together
	\ #### Give it one minute.
	#1sec ( #60 * ) CONSTANT IP_FTTL

reassemble ip datgrams

The datagrams souce and id is used as a hash value into hash table. The hash table contains heads for link list. The corrent link list entry is determined using the datagrams source, detination, id and protocol.

The table entry includes all information on datagram being reconstucted, including pointers to ip packets received.

A table entry is constucted when the first fragment arrives. It is removed by a low level task. The ip packets exist until the datagram is complete. A complete datagram is then reconstructed and returned. All the old ip fragments are discarded. However the table entry remains untill the low level task removes it.

If the table status is valid the ip pointers point to ip packets, if the status is free or bogus, the ip packets are_heing or have_been returned.

The spec calls for scr dst protocal and id to be the id fields for a datagram. The hash value doesn't have to use all, the comparison does. 

 
	: frag_hash { ( scr id -- hash_value ) }{
				  6 bytes  %hashdata }
		%hashdata 4 + W!
		%hashdata !
		%hashdata 6 checksum #frag_head_mask AND
	;
	

	: _link_in_fragment_table ( table -- )
		DUP _fpt_src + @ 
		OVER _fpt_id + @ frag_hash %fragment_heads + link_double
	;

	: _new_fragment_table { variable %pep -- ( addr ) }
		[ _fpt_length _#fpt_default_fp _fp_length * + ]T LITERAL 
		
		get_free_buffer
		DUP buffer_size %fragment_memory_use @ + 
		DUP _#fragment_memory_limit > IF
			kill_free_buffer
			ABORT" fragment memory use exceeded"
		THEN
		%fragment_memory_use !

		\ addr(--
		\ set head to zero
		DUP _fpt_length ERASE
		\ the value to set _fpt_fp_available to is not determined
		\ by _#fpt_default_fp but but the actual length of the
		\ buffer returned.
		DUP buffer_size _fpt_length - _fp_length /
		OVER _fpt_fp_available + !
		
		\ we can be accepting datagrams from multiple destinations
		\ so that needs to be tested also.
		%pep @ [ ep_data ip_id + ]T LITERAL + W@ OVER _fpt_id + !
		%pep @ [ ep_data ip_src + ]T LITERAL + @ OVER _fpt_src + !
		%pep @ [ ep_data ip_dst + ]T LITERAL + @ OVER _fpt_dst + !
		%pep @ [ ep_data ip_proto + ]T LITERAL + B@ OVER _fpt_proto + !
	
		IP_FTTL xclock+ @ + OVER _fpt_ttl + !
		IPFF_VALID OVER _fpt_state + !
	;

	\ create a new table with room for twice as many pointers.
	\ Others link it in. Also make the table we are copying the
	\ old pointers from invalid.
	: _extend_table { variable %table -- ( table ) }
		%table @ _fpt_fp_available + @ 2* _fp_length * _fpt_length +

		get_free_buffer
		DUP buffer_size %fragment_memory_use @ + 
		DUP _#fragment_memory_limit > IF
			kill_free_buffer
			ABORT" fragment memory use exceeded"
		THEN
		%fragment_memory_use !

		\ update with old data
		\ new_table(--
		\ This will copy the old +fpt_fp_used value. Greate care has been 
		\ taken to make all table data independent of the tables
		\ base address
		%table @ OVER %table @ buffer_size MOVE
		DUP buffer_size _fpt_length - _fp_length /
		OVER _fpt_fp_available + !
		IPFF_VALID OVER _fpt_state + !
	;

	\ on exit there is a table to place the fragment
	: _find_table  { variable %pep -- ( table ) }
		%pep @ [ ep_data ip_src + ]T LITERAL + @
		%pep @ [ ep_data ip_id + ]T LITERAL + W@ 
		frag_hash %fragment_heads +
		\ head(--
		BEGIN
			@ ?DUP
		WHILE
			\ accept valid and bogus, valid will see the datagram
			\ added to the table bogus will see the datagram destroyed.
			DUP _fpt_state + @ IPFF_FREE <> IF 
				DUP _fpt_id + @  
				%pep @ [ ep_data ip_id + ]T LITERAL + W@ = IF
					DUP _fpt_src + @
					%pep @ [ ep_data ip_src + ]T LITERAL  + @ = IF
						DUP _fpt_dst + @
						%pep @ [ ep_data ip_dst + ]T LITERAL + @ = IF
							DUP _fpt_proto + @ 
							%pep @ [ ep_data ip_proto + ]T LITERAL + B@ = IF
								\ this is it
								\ table (--
								EXIT
							THEN
						THEN
					THEN
				THEN
			THEN
		REPEAT
		\ if we get here there is no table
		\ we must create one
		%pep @ _new_fragment_table
		DUP _link_in_fragment_table
	;


	\ The state has just been set
	\ to IPFF_FREE or IPFF_BOGUS. In both cases
	\ other code assumes the peps have been released and so there is no
	\ need to set _fpt_fp_used back to zero
	: _release_peps { variable %table -- }
		%table @ _fpt_length + DUP  
		%table @ _fpt_fp_used + @ _fp_length * + SWAP ?DO
			I _fp_pep> + @  DUP buffer_size NEGATE %fragment_memory_use +!
			kill_free_buffer
		_fp_length +LOOP
	;	
	

	\ We add all fragments to the table. It takes time to test for
	\ multiple copies and the test gets complex as the fragments
	\ may have come from multiple paths and therefor the doubles
	\ can be fragments of different lengths.
	\ Against this, double would not be common, as they will only occure
	\ on route changes.

	\ Whatever happens %pep must be consumed.
	: _add_to_table { variable %table variable %pep -- ( table ) }{
		variable %offset
		variable %data_size
	    }
		%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ IP_FRAGOFF AND 3 LSHIFT %offset !
		\ ep_ipcount set after defrag, can't use here
		%pep @ _pep>ip_data_length %data_size !

		\ does the datagram add to the known data
		\ We don't work out how much is complete until
		\ last fragment has arrived.
		%table @ _fpt_size_set + @ IF
			%table @ _fpt_no_holes_before + @ 
			\ table_offset(--
			%table @ + _fp_offset_next + @
			\ data_offset(--
			%offset @ %data_size @ + > IF
				%pep @ kill_free_buffer
				%table @
				EXIT
			THEN
		THEN
 
		\ to protect ourselves from stupidity limit the amount of
		\ data that can be received per ip to something reasonable
		\ Doing this test will allow fragmentation reasseble to continue
		\ for sources not playing bad.
		%table @ _fpt_received_length + @ %data_size @ +
		DUP _#frag_max_data_length > IF
			\ length_to_date(--
			DROP
			1 %%ip_fragment_stupidity0 +!
			IPFF_BOGUS %table @ _fpt_state + !
			%pep @ kill_free_buffer
			%table @ _release_peps
			%table @
			EXIT
		THEN
		%table @ _fpt_received_length + !

		\ to protect ourselves from stupidity limit the amount of memory 
		\ that can be consumed by this function.
		\ If this comes into play fragmentation will fail randomly. Those 
		\ not playing bad will also be effected.
		%fragment_memory_use @ %pep @ buffer_size + 
		DUP _#fragment_memory_limit > IF
			\ length_to_date(--
			DROP
			1 %%ip_fragment_stupidity3 +!
			IPFF_BOGUS %table @ _fpt_state + !
			%pep @ kill_free_buffer
			%table @ _release_peps
			%table @
			EXIT
		THEN
		%fragment_memory_use !

		\ (--
		\ can we add a pointer to the current buffer if not
		\ mark this table as IPFF_FREE create a bigger table
		\ and copy the pointers created so far into the bigger table
		%table @ _fpt_fp_available + @ 
		%table @ _fpt_fp_used + @ - 0= IF
			\ have to create a larger table
			\ but first make sure a sender hasn't gone stupid.
			%table @ _fpt_fp_available + @ _#fpt_max_fp < not IF
				\ table will get removed be the timer task
				\ if the sender is sending fragments continuously
				\ things will just start again after this table entry
				\ has been timed out.
				1 %%ip_fragment_stupidity1 +!
				IPFF_BOGUS %table @ _fpt_state + !
				\ we thought it was going to be added to use but it wasn't
				%pep @ buffer_size NEGATE %fragment_memory_use @ + %fragment_memory_use !
				%pep @ kill_free_buffer
				%table @ _release_peps
				%table @
				EXIT
			THEN
			\ remember we are in high priority code, tables are
			\ removed in low level code, we can't delete table entries
			\ for any reason, that is low level codes problem.
			\ Setting state to IPED_FREE prevents the table from being used.
			\ It also stops other code from releasing buffers pointed to.
			\ This is a good thing as we are about to copy the pointers into
			\ a larger table, se we don't want someone using the old table 
			\ to delete the buffers.
			IPFF_FREE %table @ _fpt_state + !
			\ extend_table can abort
			\ (--
			%table @ 
			['] _extend_table CATCH ?DUP IF
				\ old_table $(--
				2DROP
				\ well we can't finish the job may as well 
				\ release what we have
				IPFF_BOGUS %table @ _fpt_state + !
				\ we thought it was going to be added to use but it wasn't
				%pep @ buffer_size NEGATE %fragment_memory_use @ + %fragment_memory_use !
				%pep @ kill_free_buffer
				%table @ _release_peps
				%table @
				EXIT
			THEN
			%table !
			\ have to link new table in now
			%table @ _link_in_fragment_table 
		THEN
		\ if we get here we have a place to add the entry.
		\ We move down the table until we find a offset that is less
		\ We then move entries above up and add our entry
		
		\ The last fragments will tend to come last so scan from end back
		zero
		\ counter(--
		%table @ _fpt_fp_used + @ ?DUP IF
			\ counter limit(--
			%table @ _fpt_length + _fp_offset + DUP
			\ count limit addr addr(--
			ROT 1- _fp_length * +
			\ counter first last(--
			\ The last shall be first
			DO 
				I @ %offset @ < IF
					\ new is next
					I _fp_length + _fp_offset - \ counter from (--
					DUP _fp_length + \ counter from to(--
					ROT _fp_length *
					\ from to count(--
					MOVE
					I _fp_length + _fp_offset - 
					\ entry_addr(--
					%offset @ OVER _fp_offset + !
					%pep @ OVER _fp_pep> + !
					%data_size @ %offset @ +
					OVER _fp_offset_next + !
					DROP
					\ (--
					1 %table @ _fpt_fp_used + +!
					UNLOOP
					%table @
					EXIT 
				THEN
				1+
				[ _fp_length NEGATE ]T LITERAL 
			+LOOP
		THEN
		\ count(--
		DROP

		\ has to be moved up so we can add to first postion
		%table @ _fpt_length + DUP _fp_length + 
		%table @ _fpt_fp_used + @ _fp_length * MOVE

		%table @ _fpt_length +
		%offset @ OVER _fp_offset + !
		%pep @ OVER _fp_pep> + !
		%data_size @ %offset @ +
		OVER _fp_offset_next + !
		DROP

		1 %table @ _fpt_fp_used + +!
		%table @
	;

	: _fragment_complete? { variable %table -- ( flag ) }
		\ no use trying if last fragment has not arrived
		%table @ _fpt_size_set + @ not IF
			FALSE
			EXIT
		THEN
		\ We do not add fragments that describe data below _fpt_no_holes_before
		\ _fpt_no_holes_before is an offet into the table.
		%table @ _fpt_no_holes_before + @ ?DUP IF
			%table @ +  DUP _fp_offset + @ SWAP
		ELSE
			zero %table @ _fpt_length +
		THEN
		\ start_offset valid_entry_addr(--
		%table @ _fpt_length + 
		%table @ _fpt_fp_used + @ _fp_length * + SWAP 
		\ start_offset  end_addr start_addr(--
		?DO
			\ gap if current offset is less than the offset of next packet
			\ extracted from previous.
			DUP I _fp_offset + @ 
			< IF
				\ valid_to(--
				IF
					\ we have got started but
					\ there is a gap
					I _fp_length - %table @ - %table @ _fpt_no_holes_before + !
				THEN
				UNLOOP
				FALSE
				EXIT
			THEN
			\ remember fragment from different paths may be differnt sizes
			\ as we go up we move our next pointer to the biggest found so far
			\ the previous test makes sure the current fragment is in the window
			I _fp_offset_next + @
			MAX
		_fp_length +LOOP
		\ now we have a tricky question. What happens if the last fragment
		\ lies about the amount of data sent. Can you create a consistant
		\ fragment and clobber past the end of the buffer allocated for
		\ reasseble. The answer is yes. Send lots of data then send the final
		\ fragment with a smaller offset. Another stupidity test.
		%table @ _fpt_size + @ <> IF
			\ better set a count we really would like to know if this
			\ stunt is being pulled.
			1 %%ip_fragment_stupidity2 +!
			IPFF_BOGUS %table @ _fpt_state + !
			%table @ _release_peps
			FALSE
			EXIT
		THEN
		\ we get here and the answer is yep we have it all
		TRUE
	;
			  

	: _assemble_datagram { variable %table -- ( pep ) }{
	       variable %pep 
		   variable %ipdata }
		\ the datagram length is the total data length plus the 
		\ length of the first header. We also have to leave room 
		\ for ep_data
		\ The first table entry is the first fragment, have the pointers
		\ point to this while we sort out the head
		%table @ _fpt_length + _fp_pep> + @ %pep ! 
		\ buffer big enough to fit full datagram.
		ep_data %pep @ _pep>ip_hlen + %table @ _fpt_size + @ + get_free_buffer
		\ addr(--

		\ start datagram with header
		%pep @ OVER %pep @ _pep>ip_hlen ep_data + MOVE

		\ fix up header to reflect total datagram
		%pep @ _pep>ip_hlen %table @ _fpt_size + @ + 
		OVER [ ep_data ip_len + ]T LITERAL + W!
		
		DUP [ ep_data ip_fragoff + ]T LITERAL  + W@ 
		\ want everthing but IP_MF bit.
		\ The fragment offset should be zero as
		\ first fragment in list
		[ IP_MF -1 XOR ]T LITERAL  AND 
		OVER [ ep_data  ip_fragoff + ]T LITERAL + W!

		\ now copy all the data from the fragments into the final datagram
		\ If there are multiple copies there will be multiple copies.
		\ So what?
		DUP DUP _pep>ip_hlen + ep_data + %ipdata !		
		\ new_pep(--
		%table @ _fpt_length + DUP  
		\ new_pep addr addr(--
		%table @ _fpt_fp_used + @ _fp_length * + SWAP DO
			\ new_pep(--
			I _fp_pep> + @ %pep ! 
			%pep @ DUP _pep>ip_hlen + ep_data +  
			\ from (--
			%ipdata @ I _fp_offset + @ + 
			\ from to (--
			%pep @ [ ep_data ip_len + ]T LITERAL + W@ %pep @ _pep>ip_hlen - MOVE
		_fp_length +LOOP
		\ new_pep(--
	;
ip re-assemble
 
	\ if the output is zero we cannot give you a complete
	\ datagram yet. 
	: ip_reassemble { variable %pep -- ( %pep|0 ) }{
		variable %table
		}
		\ did datagram get fragmented
		%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ 
		[ IP_FRAGOFF IP_MF OR ]T LITERAL AND not IF
			\ This is complete. There may be fragments for this datagram
			\ as it may have been sent by two paths. We could look now
			\ and delete such fragments ( RFC791 recommends such action)
			\ however protocol have to be able to handle multiple delivery so
			\ if reassembler is completed there is no problem. Timeout will deal 
			\ with incomplete datagrams.
			\ This is the common paths. It is better to go for speed in this
			\ path.
			%pep @
			EXIT
		THEN
		\ (--
		\ _find_table can abort if we run out of memory
		%pep @ ['] _find_table CATCH ?DUP IF
			\ pep $(--
			2DROP
			%pep @ kill_free_buffer
			zero
			EXIT
		THEN
		\ addr(--
		%table !
		\ (--
		\ Are we trying to fix the unfixable
		%table @ _fpt_state + @ 
		IPFF_VALID <> IF
			%pep @ kill_free_buffer
			zero
			EXIT
		THEN

		\ is this the last
		%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ IP_MF AND not IF
			\ yep we may not have all the data but we can now work out the length
			%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ IP_FRAGOFF AND 3 LSHIFT
			\ ep_ipcount set after defrag can't use here
			%pep @ _pep>ip_data_length +
			%table @ _fpt_size + !
			TRUE %table @ _fpt_size_set + !
		THEN

		\ if there are too many fragments for the current table
		\ a new table is created. So on return we have to set %table
		\ just in case
		%table @ %pep @ _add_to_table %table !
		\ did adding this fragment lead to the unfixable
		%table @ _fpt_state + @ IPFF_VALID <> IF
			zero
			EXIT
		THEN
		\ Do we have the lot
		%table @ _fragment_complete? 
		IF
			%table @ _assemble_datagram
			\ pep(--
			IPFF_FREE %table @ _fpt_state + !
			%table @ _release_peps
			EXIT
		THEN	
		\ we have added fragment to table and that is that
		zero
	;
reassemble timeout

We need to talk about this a bit. Most of the fragminatation problem is dealt with in high level tasks. The high level tasks cannot use a table entry that has been set to IPFF_FREE. So when we see that state so we can be sure the table entry is stable.

High level tasks can change the state of a table entry from valid to free or bogus. When a high level tasks changes the state it releases all the pep packets. This code assumes that has been done.

A table entry that has been set to bogus is removed by timeout. This means that bogus fragments are removed from the system directly from the time we conclude we are being sent rubbish, untill the timeout period. After the timeout period the bogus data is once again used to contruct the bogus structure. The whole process then repeats

The fragmentation timeout is set when the first fragment arrives. It is not updated as new bits come. Rememer the ip packet id is circular. If we are too generous on the reassemble time and the link is fast we could get fragments from different packets. 

 
	: _fragment_table_timeout ( --)
		[ #frag_heads_number CELLS %fragment_heads + ]T LITERAL %fragment_heads DO
			I @
			BEGIN 
				?DUP
			WHILE
				\ table_entry(--
				\ get next entry for next time around
				\ next_entry current_entry(--
				DUP @ SWAP
				\ If valid entry see if timed out
				_lock_word 
				\ if not free the entry has to be timed out
				DUP _fpt_state + @ IPFF_FREE <> IF
					DUP _fpt_ttl + @ xclock- @ + 0< IF
						\ entry has timed out
						DUP _fpt_state + @ >R
						\ it has timed out
						IPFF_FREE OVER _fpt_state + !
						_unlock_word
						\ only release peps if state was valid.
						R> IPFF_VALID  = IF
							\ Now state has been set to free we can unlock
							\ and release the peps at any rate we please
							DUP _release_peps
						THEN
					ELSE
						_unlock_word
					THEN
				ELSE
					_unlock_word
				THEN
				DUP _fpt_state + @ IPFF_FREE = IF
					DUP unlink_double
					DUP buffer_size NEGATE %fragment_memory_use +!
					DUP kill_free_buffer
				THEN

				DROP
			REPEAT
			xpause
		cell +LOOP
	;

	\ protocol queue
	\ priorities have to be maintained
	_#ip_priority_levels CONSTANT _#proto_priority_levels
	$40 CONSTANT _#proto_queue_depth

	_#proto_queue_depth _#proto_priority_levels net_queue _proto_queue

	: queue_proto { variable %pep -- }
		%pep @ _proto_queue OVER _pep>ip_priority enqueue_try IF
			%pep @ kill_free_buffer
			1 %%proto_queue_discards +!
		THEN
	;

	: queue_proto_wait ( pep --)
		_proto_queue OVER _pep>ip_priority enqueue_wait
	;

	\ If you have to queue incoming packets directly this is the one to use.
	: queue_proto_force ( pep --)
		_proto_queue OVER _pep>ip_priority enqueue_force
	;

	\ this word is used by routed, it has no other use.
	m: ( pep -- )
		ip_reassemble 
		?DUP IF
			\ pep(--
			queue_proto
		THEN		
	; overrides :consume_interface						 

	\ the local :broadcast address is called for -1. The local interface will
	\ only do this if the local device does not know it's ip address. 
	\ #### we really should step through all interface and call :consume_ip.
	\ As the datagram should be broudcast to all networks.
	\ This would require the duplication of the datagram. At the moment we generate an
	\ error. In other words we do not support a general broudcast from the 
	\ local machine.
	ram_variable %local_general_broadcast
	m: ( pep -- )
		DUP ep_nif_received + @ 
		\ pep interface(--
		DUP this = 
		SWAP 0= OR 
		\ pep flag(--
		IF 
			1 %local_general_broadcast +!
			kill_free_buffer
		ELSE
			\ received from remote source
			this :consume_interface
		THEN
	; overrides :broadcast

	\ #### temp code
	\ stupidity errors
	m: ( -- addr)
		%%ip_fragment_stupidity0
	; method :sbase

	m: ( indent --)
			CR DUP SPACES ." interface_local | " ." Object: " this .h  
			DROP send
	; overrides :print


end_class interface_local
./version081/tcp/interface_loopback.html0100777000000000000000000000437507300314371017134 0ustar rootroot COLDFORTH KERNEL

local interface

license 

 

ram_variable %loopback_object
interface_common class


	m: ( --)
		%loopback_object @ ABORT" define loopback object only once"
		this [parent] :construct
		this %loopback_object !
	; overrides :construct

		
	m: ( --)
		this [parent] :destruct
	; overrides :destruct

	\ this word is used by routed, it has no other use.
	\ do those things that are done by an interface to finish the
	\ datagram and pass the datagram onto local
	m: ( pep -- )
		\ the source address is set in the interface if not set.
		DUP [ ep_data ip_src + ]T LITERAL + @ not IF
			127.000.000.000 OVER [ ep_data ip_src + ]T LITERAL + !
		THEN
		\ the receiving interface is set.
		this OVER ep_nif_received + !
		\ the protocol is checksumed but does not need to be done
		\ as interface also checks the checksum

		\ Have to do protocol checksum as it is checked in proto_demux, and
		\ we don't want to be dealing with loopback exceptions there.
		\ udp provides the option of not checksuming the packet. But 
		\ we make no use of it as we don't want protocol specific code here.
		DUP DUP ep_proto_obj + @ ?DUP IF
			\ pep pep object(--
			:proto_checksum
			\ pep(--
			DUP
		THEN
		\ pep pep(--
		DROP
		queue_proto
	; overrides :consume_interface						 

	\ the local :broadcast address is called for -1. The local interface will
	\ only do this if the local device does not know it's ip address. 
	\ #### we really should step through all interface and call :connect_ip.
	\ This would require the duplication of the datagram. At the moment generate an
	\ error
	ram_variable %local_general_broadcast
	m: ( pep -- )
		1 %local_general_broadcast +!
		kill_free_buffer
	; overrides :broadcast

	m: ( indent --)
			CR DUP SPACES ." interface_loopback | " ." Object: " this .h  
			DROP send
	; overrides :print

end_class interface_loopback
./version081/tcp/interface_nice.html0100777000000000000000000012663307300314371016262 0ustar rootroot COLDFORTH KERNEL license
Ethernet definitions and constants
RFC894 Ethernet encapsulation
RFC1042 IEEE802 Ethernet encapsulation
RFC826 ARP protocol

If you can send RFC894 and 1042 packets, you must be able to configure and it must default to RFC894 packets. See RFC1122 Section 2.3.3.

The NICE chip can interface to byte buses and word buses. It starts up in byte mode. In this mode the data is placed on NICE chip data pins 7->0. The COLDFIRE maps the device to a word port. To be able to read and write to the device in this mode. A1 of the coldfire is commected to A0 of the nice chips. The registers are thus mapped into the low eight bytes of 16 bit values.

The mode is then altered and the registers are mapped as words. A0 of the nice chip then becomes irrelevent, A1 and A2 of the chip then select the registers. The registers are then 4 byte boundries.

Offsets when in byte mode
 
\    $00 CONSTANT #ether_reg0   
\    $02 CONSTANT #ether_reg1
\    $04 CONSTANT #ether_reg2 
\    $06 CONSTANT #ether_reg3
\    $08 CONSTANT #ether_reg4   
\    $0A CONSTANT #ether_reg5
    $0C CONSTANT #ether_reg6   
\    $0E CONSTANT #ether_reg7
Offsets when in word mode
 
    $00 CONSTANT #ether_reg10
	$04 CONSTANT #ether_reg32
    $08 CONSTANT #ether_reg54
    $0C CONSTANT #ether_reg76
	$10 CONSTANT #ether_reg98
    $14 CONSTANT #ether_regBA
    $18 CONSTANT #ether_regDC
    $1C CONSTANT #ether_regFE

%ip_address is set to the desired ip address. If not set default is used. 

 
	ram_variable %ip_address


ram_variable %nice_object


interface_common class

	1  CONSTANT _#nice_output_priorities

	#queue_list_length
	_#nice_output_priorities *
	#queue_data_length + bytes% instance_variable %%output_queue

	cell%  instance_variable %%buffer_loaded

	\ arp table is claimed by the timeout routine and by print words.
	\ the interrupt tasks do not have to claim it.
	#facility_length bytes% instance_variable %%arp_facility

The arp table is interface dependent, the arp table is indexed by host. We are talking about an internet segment. There is not going to be hundreds of entries. Each entry in this table is a linked list head. 

 	
	ARP_TSIZE CELLS bytes% instance_variable %%arptable

The NIC address has to be unigue within the network segment. It does not have to be globelly unigue. HTML did not go the way DEC intended. Ip6 will require a unigue NIC id under the subnet id, so once again the the NIC address only has to be locally unigue.

In other words if you have one coldforth system on the gateway you can leave this as is, if you have more you have to change it.

Ethernet addresses that start with 40 are locally allocated so they will not conflict with a globally allocated address. 

 	
	CREATE #$nice_default ," @CLD00"

	: $set_nif ( $ object --)
		\ addr object(--
		SWAP COUNT DROP SWAP :hwa EP_ALEN MOVE
	;

	
	: $set_hwb ( $ object --) 
		SWAP COUNT DROP SWAP :hwb EP_ALEN MOVE
	;

The output queue only has to be long enough to take up transmission latency. The interrupt has a higher priority than the routing routine so under normal operation the queue will not grow very long. Problems arise if we have retransmission errors. The interrupt code will drop the packet after 16 tries. We should start dropping packets being queued also at some point. Remember if you hold a packet in a system for more than 1 sec you have to start decrementing the hop count.

We don't want to get into that so it is best to make the output queue short enough to be completly dropped within one second if we get into trouble. ethernet runs at 10mbits. call it 1 mbyte. Packet size is about 1600bytes, say 2msec a packet. 16 * 2 = 64 msec to drop. Call in 50 msec. 20 packets max. Make it 16.

You may be tempted to argue this is too short it can't even take all the fragments from a 64k ip packet. Remeber the interrupt routine will kick in on the first fragment. The interrupt load will slow down the fragmentation code. If you can't get rid of the initial fragments bits there really is no reason to continue you may as well drop as you try to queue it for output. 

 
	$10 CONSTANT #nice_output_qsize
	: output_queue_init ( --)
		#nice_output_qsize  _#nice_output_priorities %%output_queue queue_init	
	;

Register 0, transmit status

BITDescriptionInitial Value
7TX done; reset before starting a new transmission1
6Net_busy-
5Received packet sent-
4Carrier lost; auto reset on transmission start-
3Reserved-
2Collision error; true to reset1
116 Collisions; true to reset1
0Reserved1
Initial value is 1000 0111 $87

Register 1, receive status

BITDescriptionInitial Value
7Received packet1
6Bus read error1
5DMA end of process1
4Remote control packet received1
3Short packet error1
2Aligned packet error1
1CRC packet errer1
0Received buffer overflow1
Initial value is 1111 1111 $FF

Register 2, transmit interrupts

BITDescriptionInitial Value
7TX done interrupt enable0
6--
5--
4--
3--
2Collision interrupt0
116 Collisions interrupt0
0--
Initial value is 0000 0001 $01

Register 3, receive interrupt

BITDescriptionInitial Value
7Received packet1
6Bus read error0
5DMA end of process0
4Remote control packet received0
3Short packet error1
2Aligned packet error1
1CRC packet errer1
0Received buffer overflow1
Initial value is 1000 1111 $8F

Register 4, tranmit mode

BITDescriptionInitial Value
7Collision count bit3-
6Collision count bit2-
5Collision count bit1-
4Collision count bit0-
3Reserved0
2/pin951
1Not loopback1
0Force tranmit0
Initial value is 0000 0110 $06

Register 5, recieve mode

BITDescriptionInitial Value
7Reserved0
6Rx buffer empty read only0
5Accept packets with errors0
440 bit address0
3Accept short packets0
2Reserved1
1,0Address filter01
Initial value is 0000 0101 $05

Register 6

BITDescriptionInitial Value
7Disable data link1
6Must be 11
5system byte mode0
4buffer byte mode0
3,2transmit buffer size1,0 2*2k
1,0buffer size1,1 64k
Initial value is 1100,1011 = $CB

Register 7

BITDescriptionInitial Value
7,6Mode; set normal nice00
5Power up1
4Ready pin polarity-
3,2Register bank select00
1EOP polarity0
0Byte order1
Initial value is 0010,0001 = $21 
 
	:  nice_init ( --)
		\ 64k chip
		\ 2*2k transmit buffers
		\ word system bus
		\ word buffer bus
		\ Disable data link
		$CB   [ _#ethernet_controller_base #ether_reg6 + ]T LITERAL W!
		\ reset transmit and recieve status bits
		$FF87 [ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W!
		\ enable interrupt conditions
		$8F01 [ _#ethernet_controller_base #ether_reg32 + ]T LITERAL W!
		\ pin 95 low; no loopback;NODE ID; Broadcast; and multicast
		$0506 [ _#ethernet_controller_base #ether_reg54 + ]T LITERAL W!
		\ power_up HL byte order, Disable link, 64k
		$A1CB [ _#ethernet_controller_base #ether_reg76 + ]T LITERAL W!
		%%ni_hwa
		\ addr(--
		\ byte ordr is low high for registers
		DUP char@ OVER CHAR+ char@ 8 LSHIFT +  [ _#ethernet_controller_base #ether_reg98 + ]T LITERAL W!
		CHAR+ CHAR+
		DUP char@ OVER CHAR+ char@ 8 LSHIFT +  [ _#ethernet_controller_base #ether_regBA + ]T LITERAL W!
		CHAR+ CHAR+
		DUP char@ OVER CHAR+ char@ 8 LSHIFT +  [ _#ethernet_controller_base #ether_regDC + ]T LITERAL W!
	
		DROP

		\ select the hash table and set to zero
	
		$A5CB [ _#ethernet_controller_base #ether_reg76 + ]T LITERAL W!
	
		zero [ _#ethernet_controller_base #ether_reg98 + ]T LITERAL W!
		zero [ _#ethernet_controller_base #ether_regBA + ]T LITERAL W!
		zero [ _#ethernet_controller_base #ether_regDC + ]T LITERAL W!
		zero [ _#ethernet_controller_base #ether_regFE + ]T LITERAL W!
	
		\ set to buffer registers; eable recaiver/ransmitter
		$A94B [ _#ethernet_controller_base #ether_reg76 + ]T LITERAL W!
	;



	\ called from the object under construction
	: load_nice_setup ( --)
		\ set the defaults
		#$nice_default  this $set_nif
		$EP_BRC         this $set_hwb
		#default_ip     this set_ip
		$FFFFFF00       this set_mask
		\ load user file to override
		this $" flash/init/nice_setup.html" ['] $include CATCH IF
			\ file not present			
			\ this $(--
			panic" failed to load flash/init/nice_setup.html
			2DROP
		THEN
	;

	m: ( --)
		%nice_object @ ABORT" Define nice object only once"
		this [parent] :construct
		load_nice_setup
		output_queue_init
		nice_init
		%%arp_facility #facility_length ERASE
		%%arptable ARP_TSIZE CELLS ERASE
		\ the mtu is the maximum ip packet that will fit in the datagram.
		EP_DLEN %%ni_mtu !
		NIS_UP %%ni_state !
		\ so the interrupt routine can find it
		this %nice_object !
	; overrides :construct

		
	m: ( --)
		this [parent] :destruct
	; overrides :destruct

We need to think about this. The chip has two buffers; one can be loaded while the other is sent; if we want speed we have to do this. There are two bits on the card transmit done and the transmit done interrupt bit. We cannot see the counter.

Interrupts will be enabled if transmission is occuring.

The interrupt routine will look something like this. 

 
	is_there_a_packet_in_buffer IF
		start_transmission
		is_there_a_apacket_in_queue IF
			load_buffer
		THEN
	ELSE
		is_there_a_packet_in_queue IF
			load_buffer
			start_transmission
			is_there_a_buffer_in_queue IF
				load_buffer		
			THEN
		ELSE
			disable_interrupts
		THEN
	THEN
 
 
	: out_int_enable ( --)
		[ _#ethernet_controller_base #ether_reg32 + ]T LITERAL W@
		$0080 OR 
		[ _#ethernet_controller_base #ether_reg32 + ]T LITERAL W!
	;

	: out_int_disable ( --)
		[ _#ethernet_controller_base #ether_reg32 + ]T LITERAL W@
		$FF7F AND 
		[ _#ethernet_controller_base #ether_reg32 + ]T LITERAL W!
	;

	\ yuk yuk yuk, code. But it's code or fight with DMA.
	CODE load_nice_buffer ( pep --)
		S )+ A0 MOV
		ep_len 0) D0 MOV
		\ total number of bytes
		ep_dst # D0 SUB
		\ standard requires a minimum packet length, it doesn't matter
		\ if the tail is rubbish.
		EP_MINLEN # D0 CMP LT IF
			EP_MINLEN # D0 MOV
		THEN
		ep_dst 0) A0 LEA
		_#ethernet_controller_base #ether_reg98 + # A1 MOV
		\ have to swap length to keep nice chip happy
		D0 D2 MOV 
		
		\ swap the byte order for the count
		8 # D2 ASR
		D0 D1 MOV
		8 # D1 ASL
		D2 D1 OR
		$FFFF # D1 AND
				 
		D1 A1 ) W. MOV
		1 # D0 ADD
		1 # D0 ASR
		BEGIN
			A0 )+ A1 ) W. MOV
			1 # D0 SUB
		EQ UNTIL
	NEXT

	\ for interrupt routine
	m: ( --)
		%%buffer_loaded @ IF
			\ if the buffer is loaded we can start the transmission
			\ and load the next.
			\ Interrupts will be enabled.
			\ reset transmit done
			[ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W@
			0080 AND 
			[ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W!
			\ initiate transmission
			$81 [ _#ethernet_controller_base #ether_regBA + ]T LITERAL W!

			FALSE %%buffer_loaded !
			%%output_queue dequeue DUP IF
				\ packet to load into buffer
				\ we are setting up for next packet while current is being
				\ sent, will only happen under very heavy load.
				DUP load_nice_buffer
				kill_free_buffer
				TRUE %%buffer_loaded !
				EXIT
			THEN
		ELSE
			\ buffer is not loaded
			%%output_queue dequeue ?DUP IF
				\ packet to load into buffer
				out_int_enable
				DUP load_nice_buffer
				kill_free_buffer
				\ reset transmit done
				[ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W@
				0080 AND 
				[ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W!
				\ initiate transmission
				$81 [ _#ethernet_controller_base #ether_regBA + ]T LITERAL W!
				%%output_queue dequeue ?DUP IF
					\ packet to load into buffer
					DUP load_nice_buffer
					kill_free_buffer
					TRUE %%buffer_loaded !
				THEN
				EXIT
			THEN
			\ get here and there is nothing more to do.
			out_int_disable
		THEN
	; method :write_packet

The task code will look something like this 

  
	place_packet_on_queue
	claim_device
	are_interrupts_enable IF
		release_device
		EXIT
	THEN
	execute_int_service_word
	release_device

With this code it is possible for the packet placed in queue to be long gone by the time we claim the device and test if interrupts are still enabled. The important thing is that only one task can kick things off at a time, and that it only gets kicked off when the interrupt routine is no longer running. If we queue and it gets sent before we get a chance to test the state of the interrupt routine it is a good thing. 

 
	\ :write_pep

	CODE xnop
		NOP
	NEXT

	m: ( addr --)
		xnop
		_lock_word
		\ see it interrupts are enable
		[ _#ethernet_controller_base #ether_reg32 + ]T LITERAL W@
		$0080 AND IF
			\ this will unlock
			DUP %%output_queue zero enqueue_try
			xnop
			xnop
			IF
				\ failed to queue
				kill_free_buffer
				\ if the queue is full interrupts should be enabled.
				\ if it isn't the case there is a bug and it is better
				\ we find it than hide with a kick here
				EXIT
			THEN
			DROP
			EXIT
		THEN
		out_int_enable
		DUP load_nice_buffer
		\ reset transmit done
		[ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W@
		0080 AND 
		[ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W!
		\ initiate transmission
		$81 [ _#ethernet_controller_base #ether_regBA + ]T LITERAL W!
		_unlock_word
		kill_free_buffer
	; method :write_pep

We are going to send the packet over ethernet, this means talking to IP software written by others, header has to be as per standard and that is it. 

 
	m: { variable %pep -- }

\		\ convert data to network order, for coldfire these are null operations.
\		\ put this back in for machines that store low byte first.
\		[ ep_data ip_len + ]T LITERAL %pep @ + DUP W@ hs2net SWAP W!
\		[ ep_data ip_id + ]T LITERAL %pep @ + DUP W@ hs2net SWAP W!
\		[ ep_data ip_fragoff + ]T LITERAL %pep @ + DUP W@ hs2net SWAP W!
\		[ ep_data ip_src + ]T LITERAL %pep @ + DUP @ hs4net SWAP !
\		[ ep_data ip_dst + ]T LITERAL %pep @ + DUP @ hs4net SWAP !

		\ calculate ip header checksum
		zero [ ep_data ip_cksum + ]T LITERAL %pep @ + W!
		%pep @ ep_data + %pep @  _pep>ip_hlen cksum 
		[ ep_data ip_cksum + ]T LITERAL %pep @ + W!

		\ this is the device specific bit.
		%pep @ this :write_pep

	; overrides :write_ip

Diagram below shows the stucture of the arp table. If required, an interface has a arp table, it is searched by consume_interface. Entries can only be entered into the interface arp table from the interface, as we resolve unknown entries using a broadcast message on the interface.

If there is no entry to resolve the ip address, an arp entry is created, the ip packet is queued and a arp request sent.

An arp reply that resolves the address will see the queued data sent. You only need the arp table if the hardware address cannot be created from the ip address.

The table is hashed on host address, each interface requiring it has it's own arp table. The arp cache has to be searched every time an ip packet is sent so it is important the search be reasonable fast. 

 				
	IP_ALEN 4 ??=

	: arp_host>hash  { variable %ip_addr (  -- hash ) }
		%ip_addr 4 checksum
		ARP_TSIZE_MASK AND
	;

To search the arp cache, hash the ip and then search the linked list 

 
	IP_ALEN 4 ??=
	: arp_find ( ip -- arp_entry ) 
		DUP arp_host>hash
		%%arptable +
		BEGIN
			\ ip addr (--
			@ DUP
		WHILE
			2DUP ae_pra + @ = IF
				\ ip addr(--
				NIP
				EXIT
			THEN
		REPEAT
		\ ip zero(--
		NIP
		\ zero
	; 


	\ the entry has to be created and linked into table.
	IP_ALEN 4 ??=
	: new_arp_entry ( ip --addr $|$)
		\ ip(--
		ae_length ['] get_free_buffer CATCH ?DUP IF
			\ ip ae_length $(--
			NIP NIP
			\ $(--
			EXIT
		THEN
		\ ip addr(--
		DUP ae_length ERASE
		\ The head of the queue is in the arp entry.
		\ The queue is used to queue unsent ipdatagrams.
		ARP_QSIZE _#ae_queue_priorities jump ae_queue + queue_init
		AS_PENDING OVER ae_state + !
		xclock+ @ ARP_RESEND + OVER ae_ttl + !
		\ ip addr(--
		2DUP ae_pra + !
		DUP ROT
		\ addr addr ip(--
		arp_host>hash %%arptable + 
		\ addr addr queue_head(--
		link_double  	
		\ addr(--
		zero
		\ addr $(-- 
		EXIT
	;

If there is no address you have to broadcast a arp request. We hope the receiver gets our broadcast, see's that we are trying to talk to his ip and so sends us back an arp reply with the hardware address in it. 

 
	\ arp_send
	\ pae = pointer address entry
	\ pep = pointer external packet
	: arp_send { variable %pae -- }{
		variable %pep
	}
		[ ep_data ar_length + ]T LITERAL  ['] get_free_buffer CATCH 
		
		IF
			\ failed to allocate memory to send message.
			DROP EXIT
		THEN
		%pep !
		\ we know the entire ar_ data area is set later int he code
		\  don't waste time clearing it. But clear the header of the
		\ pep
		%pep @ ep_data ERASE

		\ set hardware as appropriate for ethernet
		AR_HARDWARE hs2net %pep @ [ ep_data ar_hwtype + ]T LITERAL + W!
		\ protocol is ip as always
		EPT_IP hs2net %pep @ [ ep_data ar_prtype + ]T LITERAL + W!
		\ ep length is 6
		EP_ALEN %pep @ [ ep_data ar_hwlen + ]T LITERAL  + B!
		\ ip length is 4
		IP_ALEN %pep @ [ ep_data ar_prlen + ]T LITERAL  + B!

		AR_REQUEST hs2net %pep @ [ ep_data ar_op + ]T LITERAL + W!
		\ hardware address is always in netorder, we get it from the net
		\ we send it to the net.
		%%ni_hwa %pep @ [ ep_data ar_source_ha + ]T LITERAL + EP_ALEN MOVE
		\ Only work if IP_ALEN = 4
		%%ni_ip @ hs4net %pep @ [ ep_data ar_source_pa + ]T LITERAL  + ! 
		
		%pep @ [ ep_data ar_target_ha + ]T LITERAL  + EP_ALEN ERASE
		\ only works if IP_ALEN = 4
		%pae @ ae_pra + @ DUP hs4net %pep @ [ ep_data ar_target_pa + ]T LITERAL + !
		\ ip(--

		\ set up ep portion of packet
		%pep @ ep_nexthop + !
		\ broadcast address is destination
		%%ni_hwb %pep @ ep_dst + EP_ALEN MOVE
		EPT_ARP %pep @ ep_type + W!
		[ ep_data ar_length + ]T LITERAL %pep @ ep_len + !
		%pep @ this :write_pep 
		\ (--
	;
arp_add

We have received a arp packet, and found that there is no arp entry. Using the packet received we create an arp entry. This entry will have no ip packets queued for output.

This path is followed if we receive an arp request for our adddress. We create an arp entry for the sender of the request so we don't have to send a arp request latter on when the user of the ip packet that is about to come replies. 

  

	: arp_add { variable %pep -- variable %pae }
		%pep @ [ ep_data ar_source_pa + ]T LITERAL + @ new_arp_entry IF
			zero
		THEN
		\ addr(--
		%pae !

		%pep @ [ ep_data ar_source_ha + ]T LITERAL + %pae @ ae_hwa + EP_ALEN MOVE
		xclock+ @ ARP_TIMEOUT + %pae @ ae_ttl + !
		AS_RESOLVED %pae @ ae_state + !
	;

If the hardware address wasn't available the packet was queued in :consume_interface. All the things that ip>wire has to do still have to be done. 

 
	: arp_queue_send { variable %pae -- }
		%pae @ ae_queue + BEGIN
			DUP dequeue DUP
		WHILE
			%pae @ ae_hwa + OVER ep_dst + EP_ALEN MOVE
			\ queue addr(--
			ip>wire DROP
			\ queue(--			
		REPEAT
		\ queue zero(--
		2DROP
	;

arp_in This will get called because ep_type is EPT_ARP.

 
	: arp_in { variable %pep -- }{
			variable %pae
		}
		\ data that has to be converted from network byte order
		\ make sure packet is as expected.
		\ code 01 for ethernet
		%pep @ ep_len + @ ep_data - ar_length 
		< IF
			%pep @ kill_free_buffer
			EXIT
		THEN
		%pep @ [ ep_data ar_hwtype + ]T LITERAL + W@ net2hs 	
		AR_HARDWARE 
		<> IF
			%pep @ kill_free_buffer 
			EXIT
		THEN
		
		\ protocol type must be ip
		%pep @ [ ep_data ar_prtype + ]T LITERAL + W@ net2hs EPT_IP 
		<> IF
			%pep @ kill_free_buffer 
			EXIT
		THEN

		\ if it isn't 6 we have no idea what is going on
		%pep @ [ ep_data ar_hwlen + ]T LITERAL + B@ EP_ALEN 
		<> IF
			%pep @ kill_free_buffer 
			EXIT
		THEN

		\ if it is ip and not four wrong protocol. I wonder if version
		\ 6 still used 800.
		%pep @ [ ep_data ar_prlen + ]T LITERAL + B@ IP_ALEN 
		<> IF
			%pep @ kill_free_buffer 
			EXIT
		THEN


		\  See if entry in cache for ip address supplied
		%pep @ [ ep_data ar_source_pa + ]T LITERAL + @ net4hs arp_find 
		DUP %pae !


		\ if there is a cache entry %pae will now be non zero
		IF
			\ We have the hardware address. Here we should consider people telling lies.
			\ The way the code is written the arp message has to come from the same 
			\ physical net.
			\ But we could get two replies the one that lies and the one that tells the
			\ truth. There really is noway of knowing so we just accept the last.
			%pep @ [ ep_data ar_source_ha + ]T LITERAL + %pae @ ae_hwa + EP_ALEN MOVE
			%pae @ ae_state + @ AS_PENDING = IF
				AS_RESOLVED %pae @ ae_state + !
				xclock+ @ ARP_TIMEOUT + %pae @ ae_ttl + !
				%pae @ arp_queue_send
			THEN
		ELSE
				%pep @ arp_add %pae !
		THEN


		\ If someone has asked us for our hardware address we had better
		\ tell them, otherwise silence.
		xnop
		%pep @ [ ep_data ar_op + ]T LITERAL + W@ net2hs AR_REQUEST = IF
			\ is it our ip address
			%pep @ [ ep_data ar_target_pa + ]T LITERAL +  @ %%ni_ip @ = IF
				xnop
				\ yep it was us
				\ The packet type ( ep_type ) is already EPT_ARP
				\ have to create a reply
				AR_REPLY hs2net %pep @ [ ep_data ar_op + ]T LITERAL + W!
				\ swap source and target pa
				%pep @ [ ep_data ar_target_pa + ]T LITERAL + @

				%pep @ [ ep_data ar_source_pa + ]T LITERAL + @ 
				%pep @ [ ep_data ar_target_pa + ]T LITERAL + !

				%pep @ [ ep_data ar_source_pa + ]T LITERAL + ! 
	
				%pep @ [ ep_data ar_source_ha + ]T LITERAL +   
				%pep @ [ ep_data ar_target_ha + ]T LITERAL + EP_ALEN MOVE

				%%ni_hwa %pep @ [ ep_data ar_source_ha + ]T LITERAL + EP_ALEN MOVE


				%pep @ [ ep_data ar_target_pa + ]T LITERAL + @
				%pep @ ep_nexthop + !

				[ ep_data ar_length + ]T LITERAL %pep @ ep_len + !
			
				\ The link layer specific stuff the source adddress has to become
				\ the destionation and the source has to be set to our address.
				\ This may seem a strang place to do it but remember the destination
				\ address is normally resolved by looking up the arp table. We are below
				\ that.
				%pep @ ep_src + %pep @ ep_dst + EP_ALEN MOVE
				%%ni_hwa %pep @ ep_src + EP_ALEN MOVE
			xnop
				%pep @  this :write_pep
			ELSE
				%pep @ kill_free_buffer
			THEN 
		ELSE
			%pep @ kill_free_buffer
		THEN
	;

consume_interface The packets still has to be fragmented, the ip header changed to netorder, and the ip header checksum calculated. All this is done in ip>wire. This word only deals with getting the hardware address. 

 
	\ this word is used by routed, it has no other use.
	m: { variable %pep -- }
		%%ni_state @ NIS_UP <> IF
			%pep @ kill_free_buffer
			EXIT
		THEN
		\ if hardware source not set; set it.
		%pep @ ep_src + @ not IF
			%%ni_hwa %pep @ ep_src + EP_ALEN MOVE
		THEN
		\ if software source not set; set it.
		%pep @ [ ep_data ip_src + ]T LITERAL + @ not IF
			%%ni_ip @ 	%pep @ [ ep_data ip_src + ]T LITERAL + !
		THEN
		\ calculate the protocol checksum.
		\ an incomeing packet routed and sent on its way will not have ep_proto_obj
		\ set; this is a good thing as the packet may be a fragment and the first
		\ few bytes may have nothing to do with the protocol header.
		%pep @ ep_proto_obj + @ IF
			 %pep @ %pep @ ep_proto_obj + @ :proto_checksum	
		THEN

		\ Is the nexthop a ip broadcast address; if so use the hardware
		\ broadcast address. 
		%pep @ ep_nexthop + @ is_broadcast? IF
			%%ni_hwb %pep @ ep_dst + EP_ALEN MOVE
			%pep @ ip>wire DROP
			\ (--
			EXIT
		THEN
		\ Look up the hardware address. Although multiple tasks are using
		\ the arp cache the code has been written so we don't have to claim the cache.
		%pep @ ep_nexthop + @ 
		arp_find 
		
		?DUP IF
			\ ace(--
			DUP ae_state + @ AS_RESOLVED = IF
				\ ace(--
				\ we have the hardware address
				ae_hwa + %pep @ ep_dst + EP_ALEN MOVE
				\ (--
				xnop
				%pep @ ip>wire DROP
				EXIT
			THEN
			\ ace(--
		ELSE
			\ no cache entry
			\ (--
			%pep @ ep_nexthop + @ 
			new_arp_entry IF
				\ we didn't have the memory to allocate the arp entry
				%pep @ kill_free_buffer
				\ (--
				EXIT
			THEN
			\ ace(--
			\ if we fail to send drop error 
			\ it will get resent later
			DUP arp_send 
			\ ace(--
		THEN
		\ ace(--
		\ If we get here the hardware message is not yet resolved. We have to 
		\ queue the message. If the queue is full we drop the packet
		%pep @ SWAP ae_queue + zero enqueue_try IF
			\ already too many packets queued pending an outcome
			%pep @ kill_free_buffer
			\ (-- 
			EXIT
		THEN
	; overrides :consume_interface  ( pep -- )

A broadcast to the local net will come in, go through the routing table and come back here. We place the packet in the wire by calling :consume_interface

A broadcast from the local net will come in, go through the routing table and come back here. We can detect this by looking at ep_nif_received, if it is equal to this then the packet should be sent to the local interface. 

 
	m: ( pep --)
		DUP ep_nif_received + @ this = 
		IF
			%local_object @ :consume_interface
		ELSE
			this :consume_interface
		THEN
	; overrides :broadcast

	\ process options in incoming datagrams
	\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

	\ the address points to an option, the output address is the byte
	\ after
	
	\ If we return true the pep will go.
	: _error_option ( option -- byte_after flag)
		TRUE
	;
 
	\ the option does nothing other than take up one byte possition
	: _align ( addr -- addr flag )
		1+ FALSE
	;

	\ 
	\ _timestamp
	\ ------------------------------------------------------------------
	: _time_only { variable %option -- ( addr_after_option flag ) }{
		\ stucture of option head
		0 
		DUP CONSTANT _#code  1+
		DUP CONSTANT _#len   1+
		DUP CONSTANT _#ptr   1+
		DUP CONSTANT _#flags DROP 
		$80000000 CONSTANT #time_non_standard }
		\ do we have room to add the timestamp
		\ We subtract one because the ptr is one based.
		\ We add 4 because we want to add a 4 byte value.
		\ We only have problems if the resultant value is 
		\ greater than len,
		%option @ _#ptr + B@ 
		4 MAX
		1 - 4 +
		%option @ _#len + B@ > IF
			\ list is full; update overflow count and exit
			%option @ _#flags + B@ $F0 AND $F0 = IF
				\ overflow in overflow
				%option @ DUP _#len + B@ + 
				FALSE
				EXIT
			THEN
			%option @ _#flags + B@ DUP 4 RSHIFT 1+ 4 LSHIFT SWAP $0F AND OR
			%option @ _#flags + B!
			%option @ DUP _#len + B@ + 
			FALSE
			EXIT
		THEN
		\ there is room to add time
		%option @ _#ptr + B@ DUP 
		\ length of area being updated.
		4 + %option @ _#ptr + B!
		@standard_ms
		\ hs4net
		SWAP 1- %option @ + unaligned!
		%option @ DUP _#len + B@ +
		FALSE
		EXIT
	;

	: _time_and_ip { variable %option ( -- after_option flag ) }{
		0 
		DUP CONSTANT _#code  1+
		DUP CONSTANT _#len   1+
		DUP CONSTANT _#ptr   1+
		DUP CONSTANT _#flags DROP 
		$80000000 CONSTANT #time_non_standard }
		\ do we have room to add the timestamp
		\ We subtract the one because the ptr is one based.
		\ We add 8 because we want to add a 4 byte value.
		\ We only have problems if the resultant value is 
		\ greater than len,
		%option @ _#ptr + B@ 
		4 MAX 
		1 - 8 +
		%option @ _#len + B@ > IF
			\ list is full; update overflow count and exit
			%option @ _#flags + B@ $F0 AND $F0 = IF
				\ overflow in overflow
				%option @ DUP _#len + B@ + 
				FALSE
				EXIT
			THEN
			%option @ _#flags + B@ DUP 4 RSHIFT 1+ 4 LSHIFT SWAP $0F AND OR
			%option @ _#flags + B!
			%option @ DUP _#len + B@ + 
			FALSE
			EXIT
		THEN
		\ we now add time and ip; this is called from a interface method
		\ so we can access the instance variable directly
		%option @ _#ptr + B@ DUP 
		\ length of area being updated
		8 + 
		%option @ _#ptr + B!
		%%ni_ip @
		\ hs4net
		OVER 1- %option @ + unaligned!

		@standard_ms
		\ hs4net
		\ -1 because the pnt is one based
		\ 4 + because we are setting the time part of the 8 byte
		\ option
		SWAP 3 + %option @ + unaligned!
		%option @ DUP _#len + B@ +
		FALSE
		EXIT
	;


	: _time_if_ip { variable %option ( --- addr1 flag ) }{
		variable %option_end
		zero
		DUP CONSTANT _#code  1+
		DUP CONSTANT _#len   1+
		DUP CONSTANT _#ptr   1+
		DUP CONSTANT _#flags 1+
		DUP CONSTANT _#data DROP 
		$80000000 CONSTANT #time_non_standard }
		\ scan through the ip's saved in option, If any match out ip 
		\ record the current time.
		%option @ DUP DUP _#len + B@ + %option_end !
		_#data + BEGIN
			\ pointer(--
			DUP %option_end @ < not IF
				DROP
				%option @ DUP _#len + B@ +
				FALSE
				EXIT
			THEN
			DUP unaligned@ %%ni_ip @ = IF
				\ the ip mataches
				@standard_ms
				\ hs4net
				OVER 4+ unaligned!
			THEN
			8 +
		AGAIN
	;

	\ the standard say's all unknown options will still have
	\ a count. We just drop datagrams with unknown options, so there
	\ is no reason to maintain the option pointer. Just indicate
	\ an error.
	: _time_flag_error  ( add -- addr flag)
		TRUE
	;

	CREATE _timestamp_vectors
		5 tw,
		' _time_only   t,      \ 0
		' _time_and_ip t,      \ 1
		' _time_flag_error t,  \ 2
		' _time_if_ip t,       \ 3
		' _time_flag_error t,  \ other

	\ the system tries to set up ticks from the default gateway on start up.
	\ If %tick_set is true we do not set the upper bit of the time, if false we
	\ do. The upper bit indicates if the supplied time is standard.
	: _timestamp { ( addr -- addr1 flag ) }{
		zero
		DUP CONSTANT _#code  1+
		DUP CONSTANT _#len   1+
		DUP CONSTANT _#ptr   1+
		DUP CONSTANT _#flags 
		DROP }
		\ we can add the timestamp. There are three options defined by the flags.
		DUP _#flags + B@ $0F AND _timestamp_vectors vector 
	;

	\ record_route
	\ -------------
	\ flag is true if option is bad
	: _record_route { variable %option -- ( addr_after flag ) }{
		zero
		DUP CONSTANT _#code  1+
		DUP CONSTANT _#len   1+
		DUP CONSTANT _#ptr   
		DROP }
		\ do we have room to add the route
		\ We subtract the one because the ptr is one based.
		\ We add 4 because we want to add a 4 byte value.
		\ We only have problems if the resultant value is 
		\ greater than len,
		%option @ _#ptr + B@ 
		\ allow for rubbish
		4 MAX 
		1 - 4 +
		%option @ _#len + B@ > IF
			%option @ DUP _#len + B@ + 
			FALSE
			EXIT
		THEN

		%option @ _#ptr + B@ DUP 
		\ length of area being updated.
		4 + %option @ _#ptr + B!
		%%ni_ip @
		\ hs4net
		SWAP 1- %option @ + !
		%option @ DUP _#len + B@ +
		FALSE
		EXIT
	;
			 
	CREATE _option_vectors 
		$0B tw,             \ number of entries
		' _error_option t,  \ 0 does not get processed here, just something to put in table
		' _align t,         \ 1 align
		' _error_option t,  \ 2 security, you hsve to be kidding
		' _error_option t,  \ 3 loose routeing, do not support
		' _timestamp t,     \ 4 we support this 
		' _error_option t,  \ 5 not defined
		' _error_option t,  \ 6 not defined
		' _record_route t,  \ 7 we support this
		' _error_option t,  \ 8 obsolete
		' _error_option t,  \ 9 we do not support
		' _error_option t,  \ this and higher options are not supported

	\ the option field is divided into three fields, the option number is in the
	\ low 5 bits.
	: _process_an_option ( addr_opt -- addr_after flag )
		  DUP B@ $1F AND _option_vectors vector
	;

	\ flag is true if packet should be rejected because of bad options.
	: _process_options { variable %pep -- ( flag ) }{
		variable %options_end
		}
		\ this is the common route do as little as possible
		%pep @  _pep>ip_hlen ip_options = IF
			\ no options
			\ options are ok
			FALSE EXIT
		THEN
		%pep @ [ ep_data ip_options + ]T LITERAL +
		%pep @ ep_data + %pep @ _pep>ip_hlen + %options_end !
		\ option_pointer(--
		BEGIN
			\ end of option list code is a zero option
			DUP B@ not IF
				DROP
				FALSE	
				EXIT
			THEN
			\ list has finished
			DUP %options_end @  < not IF
				DROP
				FALSE
				EXIT
			THEN
			( opt_addr -- new_option_addr FLAG )
			_process_an_option IF
				\ bad bad option
				DROP
				TRUE
				EXIT
			THEN
			DUP %options_end @ > IF
				\ if here structure of option list is rubbish
				DROP
				TRUE
				EXIT
			THEN
		AGAIN	
	;

	: _ip_in { variable %pep -- ( flag ) }

\		\ convert data to network order, for coldfire these are null operations.
\		\ put this back in for machines that store low byte first.
\		[ ep_data ip_len + ]T LITERAL %pep @ + DUP W@ net2hs SWAP W!
\		[ ep_data ip_id + ]T LITERAL %pep @ + DUP W@ net2hs SWAP W!
\		[ ep_data ip_fragoff + ]T LITERAL %pep @ + DUP W@ net2hs SWAP W!
\		[ ep_data ip_src + ]T LITERAL %pep @ + DUP @ net4hs SWAP !
\		[ ep_data ip_dst + ]T LITERAL %pep @ + DUP @ net4hs SWAP !


		\ check header checksum
		%pep @ ep_data + %pep @ _pep>ip_hlen cksum IF
			1 %%ip_checksum_errors +!
			%pep @ kill_free_buffer
			FALSE 
			EXIT
		THEN
		\ routing we do is to move packets within a control system.
		\ We are not a general purpose router. We do not accept 
		\ packets with options we do not support. End of story.
		%pep @ _process_options IF
			%pep @ kill_free_buffer
			FALSE
			EXIT
		THEN
		%pep @ queue_ip 
		TRUE
	;

The receive word must read the packet from the device if ip do the cheaks that ip required and queue the packet onto the ip_queue 

 
	CODE _read_nice_packet ( addr count (--)
		S )+ D0 MOV
		S )+ A1 MOV
		1 # D0 ADD
		1 # D0 ASR
		_#ethernet_controller_base #ether_reg98 + # A0 MOV
		BEGIN
			A0 ) A1 )+ W. MOV
			1 # D0 SUB
		EQ UNTIL
		\ reset packet ready bit.
		$8000 # D0 MOV
		D0 _#ethernet_controller_base #ether_reg10 + AB W. MOV
	NEXT

	CODE _skip_nice_packet ( addr count (--)
		S )+ D0 MOV
		1 # D0 ADD
		1 # D0 ASR
		_#ethernet_controller_base #ether_reg98 + # A0 MOV
		BEGIN
			A0 ) D1 W. MOV
			1 # D0 SUB
		EQ UNTIL
		\ reset packet ready bit.
		$8000 # D0 MOV
		D0 _#ethernet_controller_base #ether_reg10 + AB W. MOV
	NEXT

	: _receive_a_packet ( --)
		\ chip is set up to accept good packets only. Status will always 
		\ have good packet set; just drop it.
		[ _#ethernet_controller_base #ether_reg98 + ]T LITERAL W@ DROP
		\ the count; it comes in low-high needs to be swapped.
		[ _#ethernet_controller_base #ether_reg98 + ]T LITERAL W@ 
		>< 				
		DUP ep_dst + 
		\ count length(--
		['] get_free_buffer CATCH 
		
		IF
			\ haven't got the memory
			\ oh well drop packet.
			DROP
			\ count(--
			_skip_nice_packet
			EXIT
		THEN

		\ count addr(--
		DUP ep_dst ERASE
		
		\ we are the receiving interface
		this OVER ep_nif_received + !

		\ pck_count buffer(--
		2DUP ep_dst + SWAP _read_nice_packet
		
		\ The length includes the internal header, not just data received.
		SWAP ep_dst + OVER ep_len + !
		
		\ buffer(--
		DUP ep_type + W@ net2hs
	
		DUP EPT_IP = IF
			DROP
			_ip_in
			\ only active the TCP level if packet was valid
			IF 
				TRUE [ TSK9 _#level_head_restart_flag + ]T LITERAL W! 
				#tcp/ip _set_new_task_level
			THEN
			EXIT
		THEN
		DUP EPT_ARP = IF
		DROP
			\ this may result in a lot of transmission activity, as packets maybe queued
			\ for transmission on reception
			arp_in
			EXIT
		THEN
		\		DUP EPT_RARP = IF
		\			DROP
		\			rarp_in
		\			EXIT
		\		THEN
		DROP
		\ we get here we don't support it
		kill_free_buffer
	;

	\ NICE is set up to read high low byte from packet; however the status and
	\ count are low high; status doesn't matter we don't look at it as we only
	\ receive good packets. The count however has to be swapped
	m: ( --)
		BEGIN
			\ we have to read until this bit is set.
			\ That is until the receive buffer is empty.
			\ Note we reset the interrupt bit before entry.
			_#ethernet_controller_base #ether_reg54 + W@ $4000 AND not
		WHILE
			_receive_a_packet
		REPEAT
	; method :read_packet

Dequeue the pep packets and return them to the free buffer pool. This gets called if an arp entry has been timed out before it has been resolved. 

 
	: arp_dequeue ( pae --)
		ae_queue + BEGIN
			DUP dequeue DUP
		WHILE
			kill_free_buffer
		REPEAT
		2DROP
	;

Every class derived from interface_common provides a :arptimer method. There is a interface_timeout task that calls the methods at regular intervals. We have to claim a printout facility before playing with this 

 
	m: ( --)
		%%arptable ARP_TSIZE CELLS + %%arptable DO
			%%arp_facility grab
			I @
			BEGIN
				?DUP
			WHILE
				\ packet may go get next before
				DUP @ SWAP
				\ next this(--
				DUP ae_ttl + @ xclock- @ + 0< IF  \ waited to long >
					DUP ae_state + @ AS_RESOLVED = IF
						DUP unlink_double
						DUP kill_free_buffer	
					ELSE
						1 OVER ae_attempts + +!
						DUP ae_attempts + @ ARP_MAXRETRY > IF
							DUP unlink_double
							DUP arp_dequeue
							DUP kill_free_buffer
						ELSE
							ARP_RESEND OVER ae_ttl + !
							DUP arp_send 
						THEN
					THEN
				THEN
				DROP
			REPEAT
			%%arp_facility release
			xpause
		cell +LOOP
	; overrides :arptimer


	m: ( --)
		CR ." ethernet"
		CR ." ip addr   hardware address  Status       ttl secs  queued"
		%%arptable ARP_TSIZE CELLS + %%arptable DO
			%%arp_facility grab
			I @
			BEGIN
				?DUP
			WHILE
				\ this(--
				CR
				DUP ae_pra + @ .h SPACE

				DUP ae_hwa + .hwa
				DUP ae_state + @ AS_PENDING  = IF
					."  Not complete "
					."           "
					BASE @ >R
					ARP_QSIZE OVER [ ae_queue #queue_limit + ]T LITERAL + @ - .d
					DECIMAL
					R> BASE !
				THEN
				DUP ae_state + @ AS_RESOLVED  = IF
					."  Resolved     "
					BASE @ >R
					DECIMAL
					DUP ae_ttl + @ xclock- @ + #100 / 10 .l
					R> BASE !
				THEN
				@
			REPEAT
			%%arp_facility release
			xpause
		cell +LOOP
	; overrides :.arp

	m: ( indent --)
			CR DUP SPACES ." interface_nice   | " ." Object: " this .h  
			DUP this [parent] :print
			DROP send
	; overrides :print

end_class nice_interface


	ram_variable %ether_overflow
	ram_variable %ether_crc_error
	ram_variable %ether_alignment
	ram_variable %ether_short_packet
	ram_variable %ether_no_more
         
     07 2** CONSTANT  #sr_trans_done
     0F 2** CONSTANT  #sr_receive
     0E 2** CONSTANT  #sr_no_more
     0B 2** CONSTANT  #sr_short_packet
     0A 2** CONSTANT  #sr_alignment_packet_error
     09 2** CONSTANT  #sr_crc_error
     08 2** CONSTANT  #sr_receive_buffer_overflow



	ram_variable %interrupt1
	ram_variable %interrupt2
	interrupt: ethernet
		1 %interrupt1 +!
		[ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W@
		DUP [ _#ethernet_controller_base #ether_reg10 + ]T LITERAL W!
		\ status(--
		DUP %interrupt2 !
		#sr_receive OVER AND IF
			%nice_object @ IF
				%nice_object @ :read_packet
			THEN 
		THEN
		\ status(--
		#sr_trans_done OVER AND IF
			%nice_object @ IF
				%nice_object @ :write_packet
			THEN
		THEN
		\ status(--
		#sr_no_more OVER AND IF
			1 %ether_no_more +!
		THEN
		\ status(--
		#sr_short_packet OVER AND IF
			1 %ether_short_packet +!
		THEN
		\ status(--
		#sr_alignment_packet_error OVER AND IF
			1 %ether_alignment +!
		THEN
		\ status(--
		#sr_crc_error OVER AND IF
			1 %ether_crc_error +!
		THEN
		\ status(--
		#sr_receive_buffer_overflow OVER AND IF
			1 %ether_overflow +!
		THEN
		DROP
		\ (--
	;interrupt
./version081/tcp/io_protocol_common.html0100777000000000000000000001667407300314371017227 0ustar rootroot COLDFORTH KERNEL
io_protocol_common

Add to io_common those methods a protocol needs 

 
	io_common class
		\ priority you want datagrams sent at.
		\ if you don't play the priority game it will
		\ be sent as zero. Most of the internet
		\ ignores the prioroity so don't let it worry you.
		cell% instance_variable %%priority
		cell% instance_variable %%local_machine
		cell% instance_variable %%remote_machine

		cell% instance_variable %%datagram_discards  
		cell% instance_variable %%datagrams_received

		_#ip_priority_levels CONSTANT _#udp_priority_levels 
		$40 CONSTANT _#udp_queue_depth
		_#udp_priority_levels _queue_data_length 
		bytes% instance_variable %%pep_queue


		\ active_pep is set and data is extracted from the active pep 
		\ by :read and :read_line
		cell% instance_variable %%active_pep
		cell% instance_variable %%active_pointer
		cell% instance_variable %%active_count



		m: ( parent --)
			this [parent] :construct
			
			zero %%priority !
			zero %%local_machine !
			zero %%remote_machine !

			zero %%datagram_discards !
			zero %%datagrams_received !

			zero %%active_pep !
			zero %%active_count !

			\ udp_demux will call :consume_port in the hope that
			\ the packet will end up in this queue.
			\ Please note priorities are honored and high priority packets
			\ will be delivered first.
			_#udp_queue_depth _#udp_priority_levels %%pep_queue queue_init

		; overrides :construct


		: _return_unread_peps ( --)
			BEGIN
				%%pep_queue dequeue DUP not IF
					DROP
					EXIT
				THEN
				kill_free_buffer
			AGAIN
		;

		m: ( --)
			\ the unread peps have to be returned.
			_return_unread_peps
			%%active_pep @ ?DUP IF
				0 %%active_pep !
				kill_free_buffer
			THEN
			this [parent] :destruct
		; overrides :destruct




		\ method support word
		: _read_from_active_pep ( addr len -- len )
			\ two cases buffer too small and buffer big enough
			%%active_count @ OVER > IF
				\ will not all fit
				%%active_pointer @ -rot
				\ pointer addr n (-- 
				DUP NEGATE %%active_count +!
				DUP %%active_pointer +!
				DUP >R
				MOVE
				R>
			ELSE
				\ all will fit
				\ addr n (--
				DROP
				%%active_pointer @ SWAP %%active_count @ MOVE
				\ take note that if you use :read_udp_pep returning the 
				\ pep is the applications problem. We only deal with it if
				\ :read is used to get the data
				%%active_pep @ kill_free_buffer
				zero %%active_pep !
				%%active_count @
			THEN  
		;

The tcp/ip protocol deals in pep's, these are buffers will a defined structure. If a common_io class is to receive pep's it needs to have a :consume_port method defined. This is the method that will be called by :proto_demux. The method should queue the packet for the i/o object to use at it's conveniance, or if overleoad return the packet to the free buffer pool.

words common to UDP ICMP and TCP protocol are defined here 

 
		m: ( variable %pep -- )
			\ the pep is not ours to destroy.
			TRUE ABORT" :setup_protocol not overrriden"
		; method :setup_protocol

		m: ( %pep_in variable %pep_out --  )
			\ the pep is not ours to destroy.
			TRUE ABORT" :setup_protocol_from_pep not overrriden"
		; method :setup_protocol_from_pep 

		m:  ( --pep addr n )
			TRUE ABORT" :read_protocol not overrriden"
		; method :read_protocol


		\ write the data pointed to by addr and n to the pep and queue
		m: ( addr n pep --)
			kill_free_buffer
			2DROP
			TRUE ABORT" :write_protocol not overridden"
		; method :write_protocol


		\ write buffered data to storage
		m:  \ compile time ( --xt)
			\ runtime ( --)
			%%type_buffer_count @ [ ep_data ip_options udp_data + + ]T LITERAL + get_free_buffer
			DUP this :setup_protocol 
			\ addr(--
			%%type_buffer> @ %%type_buffer_count @ ROT
			this :write_protocol
			zero %%type_buffer_count !
			\ will run or set things up to run the ip routing level.
			run_tcp
		; overrides :flush_file

		\ keep going around until count is zero, each time 
		\ around we send a little more data
		: _data>type_buffer ( addr count -- false|addr count true)
			%%type_buffer> @ not IF
				\ this is the default buffer size nothing more
				\ see :buffer_size!
				%%type_buffer_size @ get_free_buffer
				%%type_buffer> !
				zero %%type_buffer_count !
			THEN	
			%%type_buffer> @ buffer_size %%type_buffer_count @ - 
			\ addr num left(--
			2DUP > IF ( will not all fit)
				\ addr count amount_to_fit(--
				\ make sure we have a type buffer
				>R \ addr count (--
				OVER %%type_buffer> @  %%type_buffer_count @ + R@ MOVE \ put in as much as we can
				\ addr count(--
				SWAP R@ + SWAP R@ -   \ update send data to reflect what has been sent
				\ addr_new count_new(--
				R> %%type_buffer_count +!
				FALSE                  \ tell :write to send the packet
				                       \ and come back again
				EXIT
			THEN
			\ data will fit in the buffer
			DROP
			\ character we are up to since last record ( eol ).
			%%type_buffer> @  %%type_buffer_count @ + SWAP \ addr to count(--
			\ update %%type_buffer_count after you have done the address calculations
			DUP %%type_buffer_count +!
			MOVE
			TRUE
		;

		m: ( addr num--)
			DUP IF  \ There is some data
					BEGIN 
						_data>type_buffer IF \ return true if all ok
							EXIT
						THEN
						\ sent the data to the device to clear the buffer
						this :flush_file
					AGAIN
			ELSE 
				2DROP 
			THEN 
		; overrides :write

The tcp/ip protocol deals in pep's, these are buffers will a defined structure. If a io_common class is to receive pep's it needs to have a :consume_port method defined. This is the method that will be called by :proto_demux. The method should queue the packet for the i/o object to use at it's conveniance, or if overload return the packet to the free buffer pool. It should not block, as doing so will stop all tcp/ip reception. 

 
		m: ( pep --)
		DUP %%pep_queue OVER _pep>ip_priority enqueue_try IF
			kill_free_buffer
			1 %%datagram_discards +!
			EXIT
		THEN
		1 %%datagrams_received +!
		DROP
		; method :consume_port


		\ communication code needs to be able to abort the connection. This
		\ is called from a thread of execution other than the one that ownes the 
		\ I/O object. Aborting is not an option.
		m: ( $ pep--)
			kill_free_buffer
			DROP
		; method :abort_connection

		\ called by timeout routine in attempt to stop timeout.
		m: ( --)
		; method :hay_you_there
		
		\ tcp server can do a listen
		m: ( --addr)
			TRUE ABORT" Can't listen using this driver"
		; method :listen

		\ tcp server has to be able to ask a tcp_client to init isself
		m: ( local_machine local_port tos pep addr --)
			TRUE ABORT" :client_int wrong driver"
		; method :client_init

		m: ( indent --)
			." io_protocol_common | This method should be overrides"
			DROP
			send
		; overrides :print

	end_class io_protocol_common
./version081/tcp/ip_packet_flow.png0100777000000000000000000001364307300314372016127 0ustar rootrootPNG  IHDRQ0PLTE{.IDATxK*Ȕm:3)g o H%keĘ(,^4ֳz_'"""""""""""""""""""""""""~֛#RcT=R#H5'"7>ǧښH{)>;<)IS_NHH>ZbEȑ" R(S2_kF'ꩶD_dvw4#%/$'u[Rf"5i9a^\鑢?E(RJ?s`D駻(R$x D'w^njxVt;~ n!IfRA*Կ-RyV;-~+~22:/m+΂Kҏ>hğWo_$^sP3V2ㆢH5R^զ -"sלH=>yg[@ycԝ}BRӜ%[E=$VISCOkXrS&%2$&>j^P_y&x~2uN=a\6ESǤ%E/KJd'Q&S҄HIl?Iʋ6lѦl?eaVmeI-l?[=) I1yn/I?*޷L?RV蓼z)S~n"e4c՝Ojt$ϑZx>z8O~doQE@OIoҽ"nз%9Tn')#RikֆR A ({.'EYJ*SOMؽ@*^{wIԻFy"u*J$)I8*ܲ]*HDe)IIR' Bǃ2@LR'2ԉ̄+uA*3J(:@6a[:LR>~TRŏ$u4"*~77fH*3^Jz"Z&xg#Tsl1#7|gH<~ύQ?j䏰ǯp>eМn7@WI-xyE6v<R_-HS u[jr_i.*|aoi@' @/̄+uA*3J(:@LR' rK*{mLLR骝VT@@*7J(:ISeHT͖DJW)=H uoH rĪ+qA*3J$)@L'I 2IlcaReԉ̄+uA*3J(:@LR'2ԉ̄+uA*3J(:@LR'2ԉ̄+u'o #2^._y<zRJ&/J-PIDc|W'Ev΂Lଦtz7I I=MЊpA;E/_;I%UwRtC@~pSͤzƗ`)5[AR'C>Ej-gi$JRTz)7җ")0Oy_ M*|/IeCKR'0)OlH-,2 WD~QW^g/J 0;OH%]OU>3UՏ*lR1TQ告O_tz\{A#KMY"T; 䕗~#HUz駗hJJF**Ry@Tl:Z-Ӯ@*]  He&\jc.*"z$R W;ؐ ӝ;ԘĽPFʤ|G:;WlH͈REч,;(l)۬<H+ToBW[tesN&5o H+bumR$BwZr\]yiPP6)SSF=E) E.Ay@*_gtT@*M U\放T!\ gH R)HJL2EHO"f#H`6D,tw }"NrGœajcRR5Tm1#eB:餫8>N*u:lFXEJpiYRs9R;7 V>,썒IڻoҬ\R{lR|Q9Eg/ϛzT )*EJ_9 VfS>7R)NjPx٬d7RogylHOjZ%6Q uaВղFG:)WO=t=ETAR`қ~sضm1T I9V{_:"E+'N#3͋nWz@&RuNCQG5ۙʑ"iT4)A't7D 7H%"Cj ؑR-*,dZ)7V :zTQZg~y1h-)Uư3R`m?Mhk RqtT@ ~R?L*H3ȾTNJMxTsB <)PʤdqTV܊YRꇍuAR3[ռ7t I3ÑtY@:p^8!5T]zS^UoJA@j AۯGKjGSj¿URW%ޤ4q?J):Q)n u.oH-c RPH-c RPT)3':r }ZJHHq N 8R'RaAj0 5O o")/ rSN<H@*7SlHM*2ΆR)zgܔKTnʥ^@*7R/lxq7IUʗANRrUnx~R$U=@@@@@@Z'ծ7@@@@@@@@j%ڔJ TJRs8&Nʅ$d\K,iF9RV4OȮ:EBij"@ʊǧ ʤH˸RԂקB8c<555_Gx.e+'K?iKcR uRK3\/)qj!R6%@@LJ)5GUH@wJI}r E)/Fx=6X:"A<mW R% H-x9)spJvzV/'%R eK?x)l8#SoUO8$em?UYlbXe'UY"IBF"N")Oy$ጪ3)\R~۫d :ID)# I(RBIz,I O 1(bIVH-RBb zуOgxԕ R<ܰiNʹ^#H]8H-IZyHU:R!E( DN yjǫHd]+y)S2\&):*`-x )S~C;2~Mo"A0ZSH*R+gA*9ו~'}US@.Q2)Q")Q")Q")Q")I8& 'R9q,Om$TV+vZA*#%I-:RT8"OMN T8^E _8^W0)&uCJHHوHHوHHوHHو{{‚Mݐq,L* COLDFORTH KERNEL

Generic words to setup ip ddtagrams

license
RFC768 UDP
RFC791 IP
RFC1122 Host requirments

We are not a router, we are a host that supports routing because we need it with our system. We do not support source routing, I am told it is a security risk ( how is beyond me). If however this is the general feeling then obviously it's support in the long term is questionable. From where I sit it is just extra code that will not be used. Source routing with the systems controlled by this codde is questionable.

The interfaces only allows datagrams with certain options in. See

options 

 
	\ don't copy byte option
	: _option_no_byte  ( from to -- from+ to+ )
		2DROP
		one zero
	;

	\ copy byte option
	: _option_byte ( from to -- from+ to+ )
		SWAP B@ SWAP B!
		one one
	;

	: _option_copy { ( from to -- from+ to+ ) }{
		variable %length
		zero
		DUP CONSTANT _#code  1+
		DUP CONSTANT _#len   1+
		DROP 
		}
		
		OVER _#len + B@ DUP %length !
		MOVE
		%length @ DUP
	;

	: _option_no_copy { ( from to -- from+ to+ ) }{
		zero
		DUP CONSTANT _#code  1+
		DUP CONSTANT _#len   1+
		DROP 
		}
		OVER _#len + B@ 
		zero
	;



	\ the default action is to skip the options using the
	\ count that follows the code. We only play with the
	\ options that need to be played with.		
	CREATE _options_table
			0B tw,
			' _option_no_byte t,  \ 0  this will never get called as top loop deals with
			' _option_byte t,     \ 1  nop
			' _option_no_copy t,  \ 2
			' _option_no_copy t,  \ 3
			' _option_copy t,     \ 4  timestamp
			' _option_no_copy t,  \ 5
			' _option_no_copy t,  \ 6
			' _option_copy t,     \ 7  record route
			' _option_no_copy t,  \ 8
			' _option_copy    t,  \ 9
			' _option_no_copy  t, \ 0A
	

|		: _option_vector  ( from to  -- from+ to+ )
			OVER B@ $1F AND _options_table vector
		;


		CREATE $option_fault ," Options incorrect"

		: _copy_options { variable %pepin variable %pepout ( -- count $ ) }{
			variable %from_addr
			variable %to_addr 
			variable %header_max }
			%pepin @  _pep>ip_hlen ip_options = IF
				\ no options
				zero zero EXIT
			THEN

			%pepin @  [ ep_data ip_options + ]T LITERAL + %from_addr !
			%pepout @ [ ep_data ip_options + ]T LITERAL + DUP %to_addr !
			%pepin @ ep_data + %pepin @  _pep>ip_hlen + %header_max !

			\ we have options
			
			BEGIN
				%from_addr @ B@ not IF
					\ end of option list
					%to_addr @ SWAP -
			
					\ round to 32 bit boundry
					\ remember header length has to be in 32 bit words
					DUP 03 AND IF
						0 %to_addr @ B!
						4 OVER 3 AND - +
					THEN
					zero
					EXIT
				THEN

				%from_addr @ %to_addr @ _option_vector 
				
				%to_addr +!
				%from_addr +!
				%from_addr @ %header_max @ > IF
					\ if the option list is shit this will happen
					DROP zero $option_fault
					EXIT
				THEN
			\ allowed to end at header.
			%from_addr @ %header_max = UNTIL
			%to_addr @ SWAP -

			\ round to 32 bit boundry
			\ remember header length has to be in 32 bit words
			DUP 03 AND IF
				\ end of option list
				\ in output
				0 %to_addr @ B!
				4 OVER 3 AND - +
			THEN
			\ things seem ok
			zero
		;

This should be protocol specific, but I know of at least one stack that is broken and expects it to be machine specific. This is the number used by UDP and TCP to id a datagram. Assume it is being updated at all priorities and protect it when in use.

Doing it this way also means we can have a common routine for generating ip headers. That is not a bad thing. 

 
	ram_variable _%datagram_number

	\ only done so access is locked, if you need to get one from 
	\ locked code do it yourself.
	: get_datagram_id ( -- num )
		_lock_word
		_%datagram_number @ 
		1 _%datagram_number +!
		_unlock_word
	;

Support routines

 
		\ setup empty ip datagram
		: setup_ip { ( source destination ) variable %option_count variable %pep --  }
			\ erase the header
			%pep @ [ ep_data ip_options + ]T LITERAL  ERASE
			\ -- ep_link         CELL+    \ link field for queues
			\ -- ep_back         CELL+    \ just in case we want to put in double link list
			\ -- ep_error        CELL+    \ address of error message or zero if none.
			\ -- ep_proto_obj    CELL+    \ so the interface can calculate the proto  checksum
	        \ -- ep_nif_received CELL+    \ The nif this packet received on
			\ -- ep_nexthop      CELL+    \ ip address
			\ --ep_len          CELL+    \ length in total including this header.
			\ the length is set to that required for a null ip packet; that is a header
			[ ep_data ip_options + ]T LITERAL %option_count @ + %pep @ ep_len + !
			\ --ep_dst          HW_AMAX +
			\ --ep_src          HW_AMAX +
			\ --ep_type         2 + 
			\ an ip packet
			\ this is the stucture we are using; has to be
			EPT_IP %pep @ ep_type + W!
			\ ep_data                  \ data in the packet
			\ ---------------------------------------------
			\ --ip_verlen      1+        \ IP version & header length (in longs)
			\ We are creating a datagram with no options.
			ip_options %option_count @ + 2 RSHIFT
			[ IP_VERSION 4 LSHIFT ]T LITERAL OR 
			%pep @ [ ep_data ip_verlen + ]T LITERAL + B!
			\ --ip_tos         1+        \ type of service
			\ --ip_len         2+        \ total packet length (in octets), including ip header
			ip_options %option_count @ +
			%pep @ [ ep_data ip_len + ]T LITERAL + W!
			\ --ip_id          2+        \ datagram id
			\ standard requires you to use protocol, datagram number, source
			\ and destination number to defrag. I happen to know at least one stack 
			\ forgot to include the proto number. The standard requires you to send
			\ out what will work and accept what won't, if it can be made to work.
			\ So we had better have a common datagram number for all protocols.
			get_datagram_id
			%pep @ [ ep_data ip_id + ]T LITERAL + W!
			\ --ip_fragoff     2+        \ fragment offset (in 8-octet's)
			\ well at this stage she isn't fragmented
			\ --ip_ttl         1+        \ time to live, in gateway hops
	        \ set by the routing task, if time is not less than following value.
			\ In other words let the routing task set this.
			RTM_INF %pep @ [ ep_data ip_ttl + ]T LITERAL + B!
			\ --ip_proto       1+        \ IP protocol
	        \ --ip_cksum       2+        \ header checksum
			\ --ip_src         IP_ALEN + \ IP address of source
			SWAP
			%pep @ [ ep_data ip_src + ]T LITERAL + !
			\ --ip_dst         IP_ALEN + \ IP address of destination 
			%pep @ [ ep_data ip_dst + ]T LITERAL + !
			
			\ set up base address and count for ip data area
			%pep @ [ ep_data ip_options + ]T LITERAL + %option_count @ + 
			%pep @ ep_ipdata + !
			0 %pep @ ep_ipcount + !
		;

	
		: add_to_ip { ( n ) variable %pep -- }
			\ the length is set to that required for a null ip packet; that is a header
			DUP %pep @ ep_len + +!
			%pep @ [ ep_data ip_len + ]T LITERAL + DUP W@ 
			\ n addr n1 (--
			jump + SWAP W!
			\ n (--
			%pep @ ep_ipcount + +!
		;

		: add_to_ip_head  ( n addr (--)
			2DUP add_to_ip
			\ subtract from ip data count
			OVER NEGATE OVER ep_ipcount + +!
			\ add to ip data pointer
			2DUP ep_ipdata + +!

			[ ep_data ip_verlen + ]T LITERAL + DUP B@ 0F AND 2 LSHIFT
			\ n addr n(--
			ROT + 
			DUP #max_ip_header > ABORT" header overflow"
			2 RSHIFT
			IP_VERSION 4 LSHIFT OR
			SWAP B!
		; 

		: setup_pep_from_pep { variable %pep_in variable %pep_out --  }{
			variable %tos 
			variable %proto }

			\ just incase we are rewriting the in datagram
			%pep_in @ [ ep_data ip_tos + ]T LITERAL + B@ %tos ! 
			%pep_in @ [ ep_data ip_proto + ]T LITERAL + B@ %proto !

			\ set up the options area
			\ has to be done before head just in case we are rewriting
			%pep_in @ %pep_out @ _copy_options ?DUP IF
				\ I think this is the best thing to do
				DROP
				\ the option length is zero so the crud will simple not be returned.
				\ we probable should send a error message.
			THEN
			\ n(--

			%pep_in @ [ ep_data ip_dst + ]T LITERAL + @
			%pep_in @ [ ep_data ip_src + ]T LITERAL + @
			ROT %pep_out @ setup_ip

			\ --ip_tos         1+        \ type of service
			\ If the user wants a special type of service he must alter the
			\ pep head himself. We use the same service as used by incoming datagram
			%tos @ %pep_out @ [ ep_data ip_tos + ]T LITERAL + B! 
			%proto @ %pep_out @ [ ep_data ip_proto + ]T LITERAL + B!

		;

ip_queue

All ip packets from all sources are queued onto one queue. The queue is priority based. This has several consequences.

  • High priority packets come first.
  • No source has priority over another, first in best dressed.
  • Routed task control is simple, it waits for a packet on the ip queue
  • Conceptually simple to follow. Ip sources have to get their packets to the ip queue getting them from there to whereever they go is another problem

Having said this, protocols use queue_ip_wait to queue there ip packets. Interfaces use queue_ip_force. So incoming packets get priority over locally generated packets.

We have to discuss the queue depth. The aim of this exercise is to send 1 meg pictures. The BVP can send pictures in 8k packets, which it should do. ( It will be interesting to see if the NT can defragment such a packet, it should, if not the picture will have to be repackaged by a BCM task). That give 128 packets a picture. THE BCM will have to fragment each packet for ethernet, each packet will be sent as 7 fragments. Giving 380 ethernet packets.

However we could use the queue_ip_wait word, not overrun the system. As the BVP uses large anounts of memory for picture storege and doesn't have several megabytes available for communication ( the BCM does) this is the solution we will use. 

 
	\ keep track of the packets discarded and why,
	ram_variable %ip_queue_discards 
	ram_variable %ip_length_error
	ram_variable %ip_header_length_error
	ram_variable %ip_version_error
	ram_variable %ip_queued

	8 CONSTANT _#ip_priority_levels
	$40 CONSTANT _#ip_queue_depth

	_#ip_queue_depth _#ip_priority_levels net_queue _ip_queue

And this is why just testing the speed of an IP stack tells you so little. You can speed it up by skipping the checks.

Anyone that assumes data comeing from anywhere in the world is structured correctly has rocks in their head. 

 
	: queue_ip { variable %pep -- }
		\ make sure version is ok
		%pep @ [ ep_data ip_verlen + ]T LITERAL + B@  $F0 AND [ IP_VERSION 4 LSHIFT ]T LITERAL <> IF
			%pep @ kill_free_buffer
			1 %ip_version_error +!
			EXIT
		THEN
		\ header isn't longer than datgram
		%pep @ _pep>ip_plen  %pep @ _pep>ip_hlen < IF
			%pep @ kill_free_buffer
			%ip_header_length_error +!
			EXIT
		THEN
		\ datgram isn't longer than packet
		%pep @ ep_len + @ ep_data - %pep @ _pep>ip_plen  < IF
			%pep @ kill_free_buffer
			1 %ip_length_error +!
			EXIT
		THEN
		xclock+ @ %pep @ ep_xclock+ + !
		%pep @ _ip_queue OVER _pep>ip_priority enqueue_try IF
			%pep @ kill_free_buffer
			1 %ip_queue_discards +!
			EXIT
		THEN
		1 %ip_queued +!
	;

	: queue_ip_wait { variable %pep -- }
		\ make sure version is ok
		%pep @ [ ep_data ip_verlen + ]T LITERAL + B@ $F0 AND [ IP_VERSION 4 LSHIFT ]T LITERAL <> IF
			%pep @ kill_free_buffer
			1 %ip_version_error +!
			EXIT
		THEN
		\ header isn't longer than datgram
		%pep @ _pep>ip_plen  %pep @ _pep>ip_hlen < IF
			%pep @ kill_free_buffer
			%ip_header_length_error +!
			EXIT
		THEN
		\ datgram isn't longer than packet
		%pep @ ep_len + @ ep_data - %pep @ _pep>ip_plen  < IF
			%pep @ kill_free_buffer
			1 %ip_length_error +!
			EXIT
		THEN
		xclock+ @ %pep @ ep_xclock+ + !
		%pep @ _ip_queue %pep @ _pep>ip_priority enqueue_wait
	;

	\ If you have to queue incoming packets directly this is the one to use.
	: queue_ip_force { variable %pep -- }
		\ make sure version is ok
		%pep @ [ ep_data ip_verlen + ]T LITERAL + B@ $F0 AND  [ IP_VERSION 4 LSHIFT ]T LITERAL <> IF
			%pep @ kill_free_buffer
			1 %ip_version_error +!
			EXIT
		THEN
		\ header isn't longer than datgram
		%pep @ _pep>ip_plen  %pep @ _pep>ip_hlen < IF
			%pep @ kill_free_buffer
			%ip_header_length_error +!
			EXIT
		THEN
		\ datgram isn't longer than packet
		%pep @ ep_len + @ ep_data - %pep @ _pep>ip_plen  < IF
			%pep @ kill_free_buffer
			1 %ip_length_error +!
			EXIT
		THEN
		xclock+ @ %pep @ ep_xclock+ + !
		%pep @ _ip_queue %pep @ _pep>ip_priority enqueue_force
	;

Many situations require the return of a error datagram. This word makes the reply according to the supplied code and destroys the datagram in error.

We are not allowed to generate an error about an error; for the ICMP datgram groupings see:

RFC1122 section 3.2.2
 
		0   CONSTANT ICT_ECHORP	  \ Echo reply
	3   CONSTANT ICT_DESTUR	  \ Destination unreachable
	4   CONSTANT ICT_SRCQ	  \ Source quench
	5   CONSTANT ICT_REDIRECT \ Redirect message type
	8   CONSTANT ICT_ECHORQ	  \ Echo request
	#11 CONSTANT ICT_TIMEX	  \ Time exceeded
	#12 CONSTANT ICT_PARAMP   \ Parameter Problem
	#13 CONSTANT ICT_TIMERQ	  \ Timestamp request
	#14 CONSTANT ICT_TIMERP	  \ Timestamp reply
	#15 CONSTANT ICT_INFORQ   \ Information request
	#16 CONSTANT ICT_INFORP	  \ Information reply
	#17 CONSTANT ICT_MASKRQ   \ Mask request
	#18 CONSTANT ICT_MASKRP   \ Mask reply
	#19 CONSTANT ICT_MAX_TYPE \ Error

	CREATE _responce_table 
		0 t,  \ ICT_ECHORP Echo reply, server is not interested
		0 t,
		0 t,
		0 t,  \ 3 ICT_DESTUR Destination unreachable
		0 t,  \ 4 ICT_SRCQ Source quench
		0 t,  \ 5 ICT_REDIRECT Redirect message type
		0 t,
		0 t,
		-1 t, \ 8 ICT_ECHORQ Echo request
		0 t,
		0 t,
		0 t,  \ 11 ICT_TIMEX Time exceeded
		0 t,  \ 12 ICT_PARAMP Parameter Problem
		-1 t, \ 13 ICT_TIMERQ Timestamp request
		0 t,  \ 14 ICT_TIMERP Timestamp reply ( server will not be interested)
		\ Information request/reply should not be implemented
		\ see RFC1122 section 3.2.2.6
		0 t, \ 15 ICT_INFORQ Information request
		0 t,  \ 16 ICT_INFORP Information reply
		-1 t, \ 17 ICT_MASKRQ Mask request
		0 t,  \ 18 ICT_MASKRP Mask reply
		0 t,  \ 19 ICT_MAX_TYPE Error
RFC1122 section 3.2.2

An ICMP error message MUST NOT be sent as the result of receiving:

  • an ICMP error message
  • a datagram destined to an IP broadcast or IP multicast address,
  • a datagram sent as a link-layer broadcast
  • a non-initial fragment
  • a datagram whose source address does not define a single host -- e.g., a zero address, a loopback address, a broadcast address, a multicast address, or a Class E address.
 
 
	: icmp_error_ok { variable %pep -- ( flag ) }
		\ if ep_error is set we are reporting an error to an application
		\ just give up
		%pep @ ep_error + @ IF
			FALSE
			EXIT
		THEN
		\ if it's not the first fragment don't report
		%pep @ [ ep_data ip_fragoff + ]T LITERAL + W@ IP_FRAGOFF AND IF
			FALSE
			EXIT
		THEN
		%pep @ [ ep_data ip_proto + ]T LITERAL + B@ IPT_ICMP = IF 
			\ we do not generate errors about datagrams that are in errors.
			\ unfortunatly not all icmp messages are errors
			%pep @ ep_ipdata + @ ic_type + B@ ICT_MAX_TYPE MIN CELLS
			_responce_table + @
			EXIT
		THEN
		\ don't respond if received from a broadcast
		%pep @ ep_nif_received + @ ?DUP IF
			:@netmask
			\ mask(--
			%pep @ [ ep_data ip_src + ]T LITERAL + @ OR -1 = IF
				FALSE
				EXIT
			THEN
		THEN
		\ ran out of excuses; lets send it
		TRUE
	; 

	

	\ the two following words use this to generate the two case.
	\ supplied destination used as source; or source is interface
	\ packet is sent out on.
	: _(icmp_error) { 
			variable %src 
			variable %type 
			variable %code 
			variable %icdata 
			variable %pep_in -- }{
			variable %pep_out
			variable %ipdata_out
			}

		[ ep_data ip_options + ic_data +  _#error_header_return_length + ]T LITERAL
		get_free_buffer %pep_out ! 
		
		%src @
		%pep_in @ [ ep_data ip_src + ]T LITERAL + @
		zero %pep_out @ setup_ip
	
		%pep_out @ ep_ipdata + @ %ipdata_out !
		
		_%icmp_object @ %pep_out @ ep_proto_obj + !
		IPT_ICMP %pep_out @ [ ep_data ip_proto + ]T LITERAL + B!
		%ipdata_out @ ic_data ERASE
		\ set up the ic header
		%type @ %ipdata_out @ ic_type + B!
		%code @ %ipdata_out @ ic_code + B!
		%icdata @ %ipdata_out @ ic_length + !
		
		\ copy error datagram header to error message
		%pep_in @ ep_data + %ipdata_out @ ic_data + 
		\ if the datagram data area is less than _#error_header_return_length
		\ (which can happen) we return all the datagram and no more.
		_#error_header_return_length %pep_in @ _pep>ip_plen MIN DUP >R MOVE
	
		\ add ic_error message length to datagram
		R> ic_data + %pep_out @ add_to_ip
		\ if we are overloaded the packet is just dropped.
		%pep_out @ queue_ip
	;

	\ packet has been routed to us; source address is the incoming
	\ destination.
	: icmp_error_message { variable %code variable %pep -- }
		%pep @ icmp_error_ok IF
			%pep @ [ ep_data ip_dst + ]T LITERAL + @ ICT_DESTUR %code @ zero %pep @
			_(icmp_error)
		THEN
		%pep @ kill_free_buffer
	;
 
	\ we are trying to route packet; source address is dependent on interface
	\ packet is sent out over
	: icmp_routing_error { variable %code variable %pep -- }
		%pep @ icmp_error_ok IF
			zero ICT_DESTUR %code @ zero %pep @ _(icmp_error)
		THEN
		%pep @ kill_free_buffer
	;

	\ ##### make sure these get used where appropiate
	: fragment_timeout_message { variable %pep -- }
		%pep @ icmp_error_ok IF
			%pep @ [ ep_data ip_dst + ]T LITERAL + @ 
			ICT_TIMEX ICC_FTIMEX zero %pep @ _(icmp_error)
		THEN
		%pep @ kill_free_buffer
	;	

	: routing_timeout { variable %pep -- }
		%pep @ icmp_error_ok IF
			zero
			ICT_TIMEX ICC_TIMEX zero %pep @ _(icmp_error)
		THEN
		%pep @ kill_free_buffer
	;
./version081/tcp/nfs.html0100777000000000000000000004121407300314372014102 0ustar rootroot COLDFORTH KERNEL b license 
 
	\ %addr_result must point to a data area that is _#fopen_length long
	ram_variable %nfs_debug
	: nfs_handle ( -- addr)
		%mount_object @ :nfs_handle 
	;

	: _nfs_open_file { variable %name_addr
	                   variable %name_count 
					   variable %addr_fhandle 
					   variable %addr_result -- }
		%addr_fhandle @  _#fh_size _data_to_stack \ data n (--
		>R
		%name_addr @ %name_count @ _string_to_stack R> +    \ data n(--
		_#nfs_program _#nfs_version _#nfs_lookup nfs_handle 
		
		_rpc
		%nfs_debug @ IF
			.S ." pep(--found nfs"
		THEN
		\ pep(--
		?DUP IF  
			DUP ep_protodata + @ _rpcr_parameters
			\ pep parameters(--
			%nfs_debug @ IF	
				.S ." pep param_add(--"
			THEN
			DUP x@ not IF
				%nfs_debug @ IF	
					.S ." pep param_add(--no error code"
				THEN
				4+ 
				%addr_result @ _#fopen_length MOVE
				kill_free_buffer
				EXIT
			ELSE
				%nfs_debug @ IF	
					.S ." pep param_add(--error code about to find unix string"
				THEN

				x@ 

				%nfs_debug @ IF	
					.S ." pep code(--about to convert unix_error"
				THEN
				_unix_code>string
				SWAP kill_free_buffer
				$ABORT
			THEN
		ELSE
			%nfs_debug @ IF	
				.S ." (-- no responce"
			THEN
			TRUE ABORT" nfs not responding"
		THEN
	;

	: _nfs_remove_file { variable %name_addr
	                   variable %name_count 
					   variable %addr_fhandle  -- }
		%addr_fhandle @  _#fh_size _data_to_stack \ data n (--
		>R
		%name_addr @ %name_count @ _string_to_stack R> +    \ data n(--
		_#nfs_program _#nfs_version _#nfs_remove nfs_handle 
		
		_rpc
		
		\ pep(--
		?DUP IF  
			DUP ep_protodata + @ _rpcr_parameters
			\ pep parameters(--
			DUP x@ not IF
				DROP
				kill_free_buffer
				EXIT
			ELSE
				x@ _unix_code>string
				SWAP kill_free_buffer
				$ABORT
			THEN
		ELSE
			TRUE ABORT" nfs not responding"
		THEN
	;

	: _nfs_remove_dir { variable %name_addr
	                   variable %name_count 
					   variable %addr_fhandle  -- }
		%addr_fhandle @  _#fh_size _data_to_stack \ data n (--
		>R
		%name_addr @ %name_count @ _string_to_stack R> +    \ data n(--
		_#nfs_program _#nfs_version _#nfs_rmdir nfs_handle 
		
		_rpc
		
		\ pep(--
		?DUP IF  
			DUP ep_protodata + @ _rpcr_parameters
			\ pep parameters(--
			DUP x@ not IF
				DROP
				kill_free_buffer
				EXIT
			ELSE
				x@ _unix_code>string
				SWAP kill_free_buffer
				$ABORT
			THEN
		ELSE
			TRUE ABORT" nfs not responding"
		THEN
	;



	: _nfs_read { variable %to_addr 
	              variable %to_len 
				  variable %offset 
				  variable %addr_fhandle --  ( len ) }
		%addr_fhandle @ _#fh_size _data_to_stack
		%offset @ SWAP 1+
		%to_len @ SWAP 1+
		zero SWAP 1+
		\ data count(--
		_#nfs_program _#nfs_version _#nfs_read nfs_handle  _rpc
		\ pep(--
		?DUP IF  
			DUP ep_protodata + @ _rpcr_parameters
			\ pep parameters(--
			DUP x@ not IF
				4+    \ skip the error code
				_#fattr_length +   \ skip the attributes
				DUP 4+ SWAP        \ pep addr_from addr_count(--
				%to_addr @ SWAP x@ DUP >R MOVE
				kill_free_buffer
				R>
				EXIT
			ELSE
				x@ _unix_code>string
				SWAP kill_free_buffer
				$ABORT
			THEN
		ELSE
			TRUE ABORT" nfs not responding"
		THEN
	;


	\ we cannot use the stack based _rpc call as the write data cannot be moved through
	\ the stack		
	: _nfs_write { ( addr n )
				  variable  %offset 
	
				  variable  %addr_fhandle --  }
		\ addr n (--
		2>R
		%addr_fhandle @ _#fh_size _data_to_stack
		zero SWAP 1+ 
		%offset @ SWAP 1+
		zero SWAP 1+
		\ data count_cells(--
		2R>
		_#nfs_program _#nfs_version _#nfs_write nfs_handle  _rpc+nfsdata
		\ pep(--
		?DUP IF  
			DUP ep_protodata + @ _rpcr_parameters
			\ pep parameters(--
			DUP x@ not IF
				4+    \ skip the error code
				\ pep addr (--
				%addr_fhandle @ _#fh_size + _#fattr_length  MOVE   \ skip the attributee
				kill_free_buffer
				EXIT
			ELSE
				x@ _unix_code>string
				SWAP kill_free_buffer
				$ABORT
			THEN
		ELSE
			TRUE ABORT" nfs not responding"
		THEN
	;
		

	: _nfs_create { variable %name_addr
	                variable %name_count 
					variable %mode
					variable %addr_fhandle  -- }
		%addr_fhandle @  _#fh_size _data_to_stack \ data n (--
		>R
		%name_addr @ %name_count @ _string_to_stack R> +    
		\ data n(--
		[
			_#mode_world_write
			_#mode_world_read +
			_#mode_group_write +
			_#mode_group_read +
			_#mode_user_write +
			_#mode_user_read +
			_#mode_reg_file +
		]T LITERAL 
		SWAP 1+
		zero SWAP 1+ \ uid
		zero SWAP 1+ \ gid
		-1   SWAP 1+ \ size
		-1   SWAP 1+ \ atime
		-1   SWAP 1+ \ mtime
		_#nfs_program _#nfs_version _#nfs_create nfs_handle 
		_rpc
		\ pep(--
		?DUP IF  
			DUP ep_protodata + @ _rpcr_parameters
			\ pep parameters(--
			DUP x@ not IF
				\ all went well
				DROP
				kill_free_buffer
				EXIT
			ELSE
				x@ _unix_code>string
				SWAP kill_free_buffer
				$ABORT
			THEN
		ELSE
			TRUE ABORT" nfs not responding"
		THEN
	;


	: _nfs_create_directory { variable %name_addr
	                variable %name_count 
					variable %mode
					variable %addr_fhandle  -- }
		%addr_fhandle @  _#fh_size _data_to_stack \ data n (--
		>R
		%name_addr @ %name_count @ _string_to_stack R> +    
		\ data n(--
		[
			_#mode_world_write
			_#mode_world_read +
			_#mode_group_write +
			_#mode_group_read +
			_#mode_user_write +
			_#mode_user_read +
			_#mode_dir +
		]T LITERAL 
		SWAP 1+
		zero SWAP 1+ \ uid
		zero SWAP 1+ \ gid
		-1   SWAP 1+ \ size
		-1   SWAP 1+ \ atime
		-1   SWAP 1+ \ mtime
		_#nfs_program _#nfs_version _#nfs_mkdir nfs_handle 
		_rpc
		\ pep(--
		?DUP IF  
			DUP ep_protodata + @ _rpcr_parameters
			\ pep parameters(--
			DUP x@ not IF
				\ all went well
				DROP
				kill_free_buffer
				EXIT
			ELSE
				x@ _unix_code>string
				SWAP kill_free_buffer
				$ABORT
			THEN
		ELSE
			TRUE ABORT" nfs not responding"
		THEN
	;

	\ reads the data into the specified buffer.
	\ the pep is killed.
	\ cookie spec where we are up to.
	\ the buffer is where we want the data
	ram_variable %test+
	: _nfs_dir {  variable %cookie variable %addr_fhandle variable %buffer -- }{
		variable %rpc_head_size }
		%addr_fhandle @  _#fh_size _data_to_stack \ data n 
		%cookie @ SWAP 1+
		\ maximum size
		%buffer @ buffer_size SWAP 1+
		_#nfs_program _#nfs_version _#nfs_readdir nfs_handle _rpc
		\ pep (--
		?DUP IF
			DUP ep_protodata + @ 
			\ pep data(--
			DUP _rpcr_parameters 
			\ pep data parameters(--
			2DUP SWAP -
			\ pep data parameters rpc_head_size(--
			%rpc_head_size !
			NIP
			\ pep parametes(--
			DUP x@ not IF
				\ pep parameters(--
				\ all went well
				\ copy directory data into buffer, it is temting just to copy
				\ max byte but pep may be last in memory and we may ask for 
				\ a read past memory end ( wouldn't that be a hard bug to find), so.
				\ Work out the the amount of data supplied
				\ pep data(--
				4+ \ skip the status flag
				OVER ep_protocount + @ 4 - %rpc_head_size @ -
				DUP 8 < IF  \ >
					\ pep addr num(--
					2DROP
					kill_free_buffer
					TRUE ABORT" rpc, returned dir details faulty" 
				THEN
				%buffer @ SWAP MOVE
				\ pep (--
				kill_free_buffer
				EXIT
			ELSE
				\ things did not do well
				DROP
				kill_free_buffer
				TRUE ABORT" nfs directory operation failed."
				EXIT
			THEN
		ELSE
			TRUE ABORT" nfs not responding"
		THEN
	;

	zero 
	DUP CONSTANT _#nfs_dir_next                          4+  
	DUP CONSTANT _#nfs_dir_fileid                        4+
	DUP CONSTANT _#nfs_dir_name_count                    4+
	DUP CONSTANT _#nfs_dir_name 
	DROP
	\ Start again after the variable length data item
	zero 
	DUP CONSTANT _#nfs_dir_cookie                        4+
	DUP CONSTANT _#nfs_dir_end                   
	DROP

	: _nfs_cookie ( addr -- addr1 )
		DUP _#nfs_dir_name_count +
		x@ xdr_aligned +
		_#nfs_dir_name +
		_#nfs_dir_cookie +
	;


	io_common class

\		inode_interface implementation
		
		cell% instance_variable %%dir_buffer
		
		_#fopen_length bytes% instance_variable %%fhandle

 
		protected

		
		\ all openings are liked into here, this includes openings
		\ of devises and files on the device.

		ram_variable _%opened_files
			
		ram_create _%device_facility  #facility_length  ram_allot


		\ all opened inodes are liked into here
		ram_variable _%opened_inodes


		public


		\
		m:  ( parent_ihandle -- )
			\ If you want to change the root directory you open it, claim it and
			\ see that no one else has it. For this to work the open has to
			\ claim the device also.
			this :facility grab
				this [parent] :construct
			this :facility release
			zero %%dir_buffer !
		; overrides :construct

		m: ( --)
			this [parent] :destruct
			%%dir_buffer @ IF
				%%dir_buffer @ kill_free_buffer
			THEN
		; overrides :destruct


		\ After the device is opened by Sopen, the device open method is used
		\ to consume the reset of the open string.
		\ As a result the only structure that is fixed is the requirment that
		\ the open command starts with the driver name.
		\ On entry this is a device object, here we store the file name
		\ We make a inode object, this opens the file on the ibm
		\ with the device locked.
		\ We then make a file object which we return

		m: ( addr num mode-- handle )
			this :!mode 
			[CHAR] / remove_leading
			DUP not IF
				2DROP
				S" /"
			THEN
			2DUP this :!name
			\ loop until string consumed

			
			[CHAR] / left_split  \ file_addr file_num rest_addr rest_num(--
			2SWAP
			\ first open takes the file handle from the mount
			nfs_fhandle DUP not ABORT" Have to mount file system in this task"
			%%fhandle 
			_nfs_open_file
			%nfs_debug @ IF
				.S ." addr count(-- nfs open finished"
			THEN
			\ thereafter stop when we have no file name
			BEGIN 
				[CHAR] / remove_leading
				DUP 
			WHILE
				[CHAR] / left_split
				2SWAP
				%%fhandle %%fhandle _nfs_open_file
				%nfs_debug @ IF
					.S ." addr count(-- another open done"
				THEN
			REPEAT
			2DROP
			\ addr num(--
			get_filecode
			this :open_inode
			%nfs_debug @ IF
				.S ." inode_handle(-- got filecode"
			THEN
			\ inode_handle(--
			this file_class heap_object  \ file_handle(--
			DUP %%file_instance !
			%nfs_debug @ IF
				.S ." file_code(-- end :Sopen"
			THEN

		; overrides :Sopen


		m: ( --addr)
			_%opened_files
		; overrides :list_head


		\ device_common
		m: ( --addr)
			_%device_facility 
		; overrides :facility
	

		\ ----------------------------------------------------------------------
		\ this has to be exported for file as file has to know how many bytes in a block
		\ when deblocking the data. NFS can deal in 8k blocks but remember we can be using
		\ nfs over networks being used for real time data transfers. This should be set
		\ to $400. It has been tested at $2000, this tests the defrag and frag software
		\
		m: 
			$2000
		; overrides :bytes_a_zone


		\ ----------------------------------------------------------------------

		\ The file offset and disk offset are one the same
		m:  { ( file_offset ) variable _%inode -- ( disk_offset) }
		; overrides :file_offset>device_offset

		m: ( addr m -- n )
			%%seek_pointer @
			%%fhandle
			_nfs_read
			DUP %%seek_pointer +!
		; overrides :read

		m: ( addr n --)
			%%seek_pointer @ 2DUP + >R
			%%fhandle 
			_nfs_write
			R> %%seek_pointer !
		; overrides :write


		\ return file size
		m:  (  --file_size) 
			%%fhandle [ _#fh_size _#fattr_size + ]T LITERAL + @
		; overrides :@file_size


		\ handle is the file handle; we are in the device object.
		\ In this code the device object contains the fhandle for the file
		\ we should create the file, but we should not alter the fhandle of
		\ this object.
		m: ( addr n --)
			this :@mode 
			%%fhandle
			_nfs_create
		; overrides :make_file

		\ the local file system can open a file, given only the fileid as stored in the directory.
		\ The nfs functions return a fileid but there is no open function to use it with. 
		\ String manipulations with the file name is the only way to do a recursive dir.
		\ 


		\ store directory entry
		\ m: ( addr num cookie %handle -- )
		\	TRUE ABORT" Not a directory entry"
		\ ; method :put_directory_name


		
	\ will scan down buffer looking for cookie.
	: _nfs_find_cookie { ( cookie ) variable %buffer ( -- addr) }{
		variable %end_buffer 
		variable %current_entry }
		%buffer @ buffer_size %buffer @ + %end_buffer !
		%buffer @
		BEGIN
			DUP %current_entry !
			_nfs_cookie DUP  x@
			\ cookie_find addr cookie_now(--
			jump = IF
				2DROP
				%current_entry @
				EXIT
			THEN
			\ cookie addr(--
			_#nfs_dir_end +
			\ cookie addr(--
			DUP %end_buffer @ > ABORT" nfs dir record structure fault"
			DUP x@ not ABORT" Cookie should be in buffer"		
		AGAIN
	;

					

	: _nfs_next_cookie { variable %cookie variable %buffer  -- ( cookie true | false) }
		%cookie @ %buffer @ _nfs_find_cookie 
		\ addr(--
		_nfs_cookie
		_#nfs_dir_end +
		DUP x@ IF \ next entry is in buffer
			_nfs_cookie x@ 
			TRUE
			EXIT
		THEN
		\ cookie not in buffer
		\ is this last buffer
		4+ x@ IF 
			\ eof
			FALSE
			EXIT
		THEN
		\ (--
		\ new buffer. It will have the next entry at start
		\ we make no assumptions about cookie step size
		%cookie @ %%fhandle %buffer @ _nfs_dir 
		%buffer @
		DUP x@ IF
			_nfs_cookie x@ 
			TRUE
			EXIT
		ELSE
			DROP
			FALSE
			EXIT
		THEN
	;
				
	: _nfs_first_cookie {  variable %buffer -- ( cookie ) }
		 zero %%fhandle %buffer @ _nfs_dir
		 %buffer @ x@ IF
		 	%buffer @ 
		 	_nfs_cookie x@ 
		 	EXIT
		 THEN
		 ABORT" Returned nfs record poorly structured"
	;

	\ have to have next reset and eof reset when we allocate the buffer
	| : _setup_buffer ( --)
			%%dir_buffer @ not IF
				#$buffer get_free_buffer
				DUP %%dir_buffer !
				8 ERASE
			THEN
	;

		m: ( cookie--cookie true | false)
			%%dir_buffer @ _nfs_next_cookie
		; overrides :next_directory_cookie

		m: ( --cookie )
			\ search current buffer for entry
			_setup_buffer %%dir_buffer @ _nfs_first_cookie
		; overrides :first_directory_cookie



		\ directory entry name
		m: { ( cookie addr max -- actual) }{
			variable %dir_entry }
			ROT %%dir_buffer @ _nfs_find_cookie
			\ addr max addr_from(--
			%dir_entry !
			%dir_entry @ _#nfs_dir_name_count + @ MIN
			%dir_entry @ _#nfs_dir_name + -rot
			\ from to num (--
			DUP >R
			MOVE
			R>	
		; overrides :get_directory_name

We don't have a seperate rmdir word. If you look at the local file remove word you will see it goes one step further it recursivly cleans out the directory. 


		\ _#fopen_length is 104 bytes long
		\ we won't want to many of these on the the stack
		m: { ( addr n -- ) }{
			_#fopen_length bytes %temp_fhandle }
			2DUP %%fhandle %temp_fhandle _nfs_open_file
			%temp_fhandle [ _#fh_size _#fattr_mode + ]T LITERAL + @ _#mode_dir 
			AND 0<>  IF
				%%fhandle _nfs_remove_dir
			ELSE		
				%%fhandle _nfs_remove_file
			THEN
		; overrides :remove_file



		m: { ( addr n -- ) }
			%%fhandle _nfs_create_directory
		; overrides :make_directory

The inode is nothing more than a computer wide facility common to the file

When you open multiple copies of a common file they all get there own objects. The only common point is the inode. The inode can be locked by the user.

###### We could use the inode here to reduce the number of opens reflected to the remote system to one. 

 
		\ head for the device	
		m: ( --addr)
			_%opened_inodes
		; overrides :inode_head
			
		m: ( --flag)
			%%fhandle 
			[ _#fh_size _#fattr_mode + ]T LITERAL + @ _#mode_dir 
			AND 0<>  
		; overrides :?directory

		m: ( indent --)
			CR DUP SPACES ." ibm | " ." Object: " this .h  
				SPACE ." file: " this :@name TYPE
			CR DUP SPACES ." seek_value: " %%seek_pointer @ .h 
				SPACE ." timeout: " %%timeout @ .h
				." linked_objects: " this :number_of_links .h 
			DROP
			send
		; overrides :print

		  
target_also
&drivers
target_definitions

	end_class nfs

target_previous_definitions
target_previous
./version081/tcp/overview.html0100777000000000000000000001124707300314372015165 0ustar rootroot COLDFORTH KERNEL

Relevent Documents

license

General

RFC2500 The RFC that are standards
RFC1122 Host requirments
RFC1812 Router requirments

IP

RFC791 General

Internet Address Resolution Protocol

RFC814 General
RFC826 ARP standard
RFC903 RARP standard
RFC1029 Further notes

Computing the checksum

RFC1071 Checksum computation

packet structure

The ip packet is structured as shown below. An application that uses queue_ip packets must understand this, as room has to be left at the start of the packet for the ep header and the ip header. This has to be, we do not want to be doing block moves as we move the packet up/down the protocol stack.

  • pep = pointer_external_packet
  • pip = pointer_internet_packet
  • pd = pointer_data

IP packet flow

All ip packets are queued into the IP packet queue. This is a priority queue, with the packet priority field ( contained in the ip header) giving which queue level the packet is queued onto. All interfaces have a :queue_ip method. The queue_ip method expects a correctly formed ip packet. The following ip fields must be filled in

  • HLEN
  • SERVICE TYPE
  • TOTAL LENGTH
  • TIME TO LIVE
  • PROTOCOL
  • DESTINATION IP ADDRESS
  • protocol_object field must be set to a valid protocol object or be zero

If IP options are to be used they must be written in th data field and HLEN set to reflect there existance. queue_ip is a low level word, applications that use it must deal with the complications.

Routed will.

  • Use the destination address to determine which interface to send the packet to.

If the packet is queued with a source address of zero, routed will:

  • Set the source to the ip address of the interface the packet is routed to.
  • Execute the :protocol_checksum method. Some protocols cannot create
    • there checksum until the source address is known.

If the packet is queued with a source address routed assumes that the packet was sourced elsewhere.

All ip packets are taken from the ip packet queue, there is no special path for local or broadcast packets. The routing routine will determine a destination interface using the destination ip address. For local broadcast addresses it will be the broadcast_interface. For local addresses it will be a local_interface. For a remote adddress is will be a interface that can send ip packets off card.

Address resolution protocol

The address resolution protocol ( ARP) is only required if the hardware address cannot be determined from the IP address, as an example ethernet. :consume_interface will deal with the problem. It is also consume_interface's problem to fragment or defragment the packet if required. The local interface will defragment, interfaces that send packets over the wire will fragment. We do it in consume_interface so that the full outgoing record goes through routed, and the hardware address only has to be resolved for the larger packet. We defragment in the local consume_interface method because it is only then that we know the packet has to be reconstructed. We have to do it at consume_interface as write_pep ( the word one layer down) can be sending packets other than ip. It is also consume_interface that has to convert the ip header into network order, and checksum the header.We don't muck around with incremental checksum updates. Such things also have to allow for ip options.

./version081/tcp/pep.png0100777000000000000000000000163607300314372013724 0ustar rootrootPNG  IHDRu44c0PLTE{)IDATx r0 @Qߥw &5/ʅsHZ ,wnq͍vYeu}H"-Z ]q5T/Poy_[V` EYw$^ҷrXu-[DL-!q廿OѶ$#G-!5ojǹBNc ,X` ,X` ,X`9$γ(O.z簌ϰ啇u? Ke}8`Ke}L>Cl[nE%q}lmZϣߖz-חe[;Q ,X` ,X` ,X`l\} ,8{&qTе\Wе\W0$+EX%kuR%S)M-W": ,X` ,X` ,X,m9bSrsXs ˽|z [jsP?i1=,,rw7˴`v5XeeD[X` ,X` ,X)K'Fyyy"KgX ,Hf|Od}U-2,X%MKv%EK~愞%=K5K>,jy6ZhYC]oYLK崙aiLKeBXZ-3lw* ,X` ,X` ,X`/-wX`WMOIENDB`./version081/tcp/pep_h.html0100777000000000000000000001636007300314372014413 0ustar rootroot COLDFORTH KERNEL

codes that can be stored in the ep_type field.

license

These are the ethernet codes, the sames codes are however used for all interfaces 

 
	0x0800            CONSTANT EPT_IP     \ type: Internet Protocol
	0x0806            CONSTANT EPT_ARP    \ type: ARP
	0x0805            CONSTANT EPT_RARP   \ type: Reverse ARP

external packet

 
.S .( into pep)
	\ the pep packet preamble used to control it's path 
	6 CONSTANT HW_AMAX

	zero
	DUP CONSTANT ep_link         CELL+    \ link field for lists
	DUP CONSTANT ep_back         CELL+    \ just in case we want to put in bouble linked list
	DUP CONSTANT ep_xclock+      CELL+    \ received time
	DUP CONSTANT ep_error        CELL+    \ address of error message or zero
	\ so the interface can calculate the protocol checksum.
	DUP CONSTANT ep_proto_obj    CELL+    \
	DUP CONSTANT ep_nif_received CELL+    \ The nif this packet received on
	DUP CONSTANT ep_nexthop      CELL+    \ ip address 
	\ pointers and counts used in further procesing
	DUP CONSTANT ep_ipdata       CELL+    \ pointer to ipdata
	DUP CONSTANT ep_ipcount      CELL+    \ count of ip bytes
	DUP CONSTANT ep_protodata    CELL+    \ pointer to protocol data
	DUP CONSTANT ep_protocount   CELL+    \ count of protocol bytes

	\ used by tcp
	DUP CONSTANT ep_start_seq    CELL+    \ the first sequence in packet
	DUP CONSTANT ep_end_seq     CELL+    \ the last sequence in packet

	\ data area to support tcp
	DUP CONSTANT ep_tcp_xclock   CELL+
	DUP CONSTANT ep_tcp_tries    CELL+

	DUP CONSTANT ep_len          CELL+    \ length in total including this header.
	DUP CONSTANT ep_dst          HW_AMAX +
	DUP CONSTANT ep_src          HW_AMAX +
	DUP CONSTANT ep_type         2 + 
		CONSTANT ep_data                  \ data in the packet

Internet Protocol (IP) Constants and Datagram Formats

 
	4    CONSTANT IP_ALEN       \ IP address length in bytes (octets)
	$20  CONSTANT IP_ALEN_BITS  \ number of bits in IP address
	: ip_classa ( ip_addr --flag )  $80000000 AND not ;         \ IP Class A address
	: ip_classb ( ip_addr --flag )  $C0000000 AND $80000000 = ; \ IP Class B address
	: ip_classc ( ip_addr --flag )  $E0000000 AND $C0000000 = ; \ IP Class C address
	: ip_classd ( ip_addr --flag )  $F0000000 AND $E0000000 = ; \ IP Class D address
	: ip_classe ( ip_addr --flag )  $F8000000 AND $F0000000 = ; \ IP CLass E address
Some Assigned Protocol Numbers
 
	1    CONSTANT IPT_ICMP      \ protocol type for ICMP packets
	6    CONSTANT IPT_TCP       \ protocol type for TCP packets
	8    CONSTANT IPT_EGP       \ protocol type for EGP packets
	$11  CONSTANT IPT_UDP       \ protocol type for UDP packets

Struct ip header. Data offsets are as put out on wire. For the internet the byte order has to be in network order ( same as coldfire). For communication between programs and cards byte order is in coldfire order. Remeber that the header can be followed by option bytes so you have to use the word _pep>ip_hlen to determine the actual header length. 

 
	zero
	DUP CONSTANT ip_verlen      1+        \ IP version & header length (in longs)
	DUP CONSTANT ip_tos         1+        \ type of service
	DUP CONSTANT ip_len         2+        \ total packet length (in octets)
	DUP CONSTANT ip_id          2+        \ datagram id
	DUP CONSTANT ip_fragoff     2+        \ fragment offset (in 8-octet's)
	DUP CONSTANT ip_ttl         1+        \ time to live, in gateway hops
	DUP CONSTANT ip_proto       1+        \ IP protocol (see IPT_* above)
	DUP CONSTANT ip_cksum       2+        \ header checksum
	DUP CONSTANT ip_src         IP_ALEN + \ IP address of source
	DUP CONSTANT ip_dst         IP_ALEN + \ IP address of destination
		CONSTANT ip_options               \ start of options


	4          CONSTANT IP_VERSION              \ current version value

	$2000 CONSTANT IP_MF                  \ more fragments bit
	$4000 CONSTANT IP_DF                  \ don't fragment bit
	$1FFF CONSTANT IP_FRAGOFF             \ fragment offset mask
	$E0   CONSTANT IP_PREC                \ precedence portion of TOS



	#20   CONSTANT IPMHLEN                \ minimum IP header length (in bytes)
	
	$3C   CONSTANT #max_ip_header         \ maximum ip header length in bytes
IP options
  
	$80   CONSTANT IPO_COPY               \ copy on fragment mask
	$60   CONSTANT IPO_CLASS              \ option class
	$17   CONSTANT IPO_NUM                \ option number

	$00   CONSTANT IPO_EOOP               \ end of options
	$01   CONSTANT IPO_NOP                \ no operation
	$82   CONSTANT IPO_SEC                \ DoD security/compartmentalization
	$83   CONSTANT IPO_LSRCRT             \ loose source routing
	$89   CONSTANT IPO_SSRCRT             \ strict source routing
	$07   CONSTANT IPO_RECRT              \ record route
	$88   CONSTANT IPO_STRID              \ stream ID
	$44   CONSTANT IPO_TIME               \ internet timestamp
Important ip addresses
 
	$FFFFFFFF CONSTANT ip_maskall
	$00000000 CONSTANT ip_anyaddr
	$7F000001 CONSTANT ip_loopback
Extracting data from the ip header using the ip base address

Things like this are required for icmp; these contain a returned datagram. 

 
	: _ip>ip_tos
		ip_tos + B@ $1C AND 2 RSHIFT
	;

	: _ip>ip_plen ( ip --packet_len)
		ip_len  + W@ 
	; inline

	: _ip>ip_hlen ( ip -- header_len)
		ip_verlen + B@ $0F AND 4* 
	;

	: _ip>ipdata ( ip -- ipdata)
		DUP _ip>ip_hlen + 
	;

	: _ip>ip_data_length ( ip -- len ) 
		DUP _ip>ip_plen
		\ pep pln(--
		SWAP _ip>ip_hlen
		\ ln hl(--
		-
		\ dl(--
	;

Most stuff is done relative to a pep address. 

 
	: _pep>ip_tos ( pep - tos )
		[ ep_data ip_tos  + ]T LITERAL + B@ $1C AND 2 RSHIFT
	; 

	: _pep>ip_priority ( pep -- priority )
		[ ep_data ip_tos + ]T LITERAL + B@ $E0 AND 5 RSHIFT ;

	: _pep>ip_hlen ( pep -- header_len)
			[ ep_data ip_verlen + ]T LITERAL + B@ $0F AND 4* 
	;

	: _pep>ipdata ( pep --pip )
		DUP _pep>ip_hlen + ep_data +
	;

	: _pep>ip_plen ( pep --packet_len)
		[ ep_data ip_len + ]T LITERAL  + W@ 
	; inline


	: _pep>ip_data_length ( pep -- len ) 
		DUP _pep>ip_plen
		\ pep pln(--
		SWAP _pep>ip_hlen
		\ ln hl(--
		-
		\ dl(--
	;
default_mask can be used to get the hash value to search the route cache, arp cache and fragment table but has nothing to do with the actual net. The net uses masks. 
 
	: ip>default_mask ( ip -- net)
		DUP ip_classc IF
			DROP $FFFFFF00 EXIT
		THEN
		DUP ip_classb IF
			DROP $FFFF0000 EXIT
		THEN
		DUP ip_classa IF
			DROP $FF000000 EXIT
		THEN
		DROP $FFFFFFFF
	;
./version081/tcp/port_mapper_client.html0100777000000000000000000000207407300314372017203 0ustar rootroot port mapper RFC1014 XDR
RFC1057 RPC
RFC1094 NFS

Thre spec looks hard doesn't it. RFC1014 describes a method to describe data, nothing more. RFC1057 describes a data structure to send for a RPC and the reply to expect. RFC1094 describes the functions available for NFS.

In the end it is all pretty simple, send a UDP datagram to port 111, with data as speced in: RFC1057 RPC and you will get back the required data, unpack the data and put it on the stack and it is done.

./version081/tcp/print_pep.html0100777000000000000000000000735707300314372015326 0ustar rootroot COLDFORTH KERNEL 
 
	: .hwa ( addr --)
		BASE @ >R
		HEX
		DUP @ u>d \ lo hi (--
		#picture_min get_buffer
		buffer #picture_min 
		[# # # # # # # # # #] TYPE
		\ addr(--
		4+ W@ u>d
		buffer #picture_min [# # # # # #] TYPE
		kill_buffer
    	R> BASE !
	; 


	: .word ( value )
		BASE @ >R
		HEX
		u>d \ lo hi (--
		#picture_min get_buffer
		buffer #picture_min [# # # # # #] TYPE
		kill_buffer
    	R> BASE !
		SPACE
	;

	: .byte ( value )
		BASE @ >R
		HEX
		u>d \ lo hi (--
		#picture_min get_buffer
		buffer #picture_min [# # # #] TYPE
		kill_buffer
    	R> BASE !
		SPACE
	;


	: .flags ( value-- )
		BASE @ >R

		binary
		u>d \ lo hi (--
		#picture_min get_buffer
		buffer #picture_min [# # # # # # # # # #] TYPE
		kill_buffer
    	R> BASE !
		SPACE
	;


	: .unknown { variable %ip_data }
		CR 
		." IP DATA:" %ip_data @ .h 
		CR
		%ip_data @ $10 DUMP
	;

	: .tcp { variable %ip_data -- }
		CR ." TCP: " %ip_data @ .h
		CR
		." scr  : " %ip_data @ #tcp_src + W@ .word 7 SPACES 
		." dst  : " %ip_data @ #tcp_dst + W@ .word 7 SPACES 
		." seq  : " %ip_data @ #tcp_seq + @  .h    3 SPACES
		." ack  : " %ip_data @ #tcp_ack + @  .h    3 SPACES

		CR
		." hlen : " %ip_data @ #tcp_offset + B@  $F0 AND 2 RSHIFT .byte 9 SPACES
		." flags: " %ip_data @ #tcp_flags  + B@ .flags 3 SPACES 
		." wind : " %ip_data @ #tcp_window + W@ .word 7 SPACES
		." check: " %ip_data @ #tcp_checksum + W@ .word 7 SPACES
		CR
		." urg_p: " %ip_data @ #tcp_urgptr + W@ .word 7 SPACES
	;

	$12 CONSTANT #.proto_max             
	CREATE .proto_table 
	' .unknown t,  \ 0 
	' .unknown t,  \ 1 - icmp
	' .unknown t,  \ 2
	' .unknown t,  \ 3
	' .unknown t,  \ 4 
	' .unknown t,  \ 5
	' .tcp t,  \ 6 - tcp
	' .unknown t,  \ 7 
	' .unknown t,  \ 8
	' .unknown t,  \ 9
	' .unknown t,  \ 0A
	' .unknown t,  \ 0B - udp
	' .unknown t,  \ 0C


	: .ip { variable %ip -- }
		." IP: " %ip @ .h CR 
		." vers : " %ip @ ip_verlen + C@ F0 AND 4 RSHIFT .byte 9 SPACES
		." hlen : " %ip @ ip_verlen + C@ 0F AND 2 LSHIFT .byte 9 SPACES
		." tos  : " %ip @ ip_tos + C@ .flags 3 SPACES
		." iplen: " %ip @ ip_len + W@ .word 7 SPACES
		CR
		." id   : " %ip @ ip_id + W@  .word  7 SPACES
		." frag : " %ip @ ip_fragoff + W@ .word 7 SPACES
		." ttl  : " %ip @ ip_ttl + B@ .byte 7 SPACES
		." proto: " %ip @ ip_proto + B@ .byte 9 SPACES
		CR
		." chksm: " %ip @ ip_cksum + W@ .word 7 SPACES
		." src  : " %ip @ ip_src + @ .h 3 SPACES
		." dst  : " %ip @ ip_dst + @ .h 3 SPACES
		." ip_op: " %ip @ _ip>ip_hlen ip_options - #12 .l
		\ the protocol may not be installed so we need to use 
		\  local definitions to print out protocol portion of packet.
		%ip @ _ip>ipdata
		%ip @ ip_proto + C@ #.proto_max MIN 4* .proto_table +
		@execute 


	;

	: .pep { variable %pep -- }
		CR ." HEADER: " %pep @ .h 
		CR
		." ln_fw: " %pep @ ep_link + @ .h 3 SPACES 
		." ln_bk: " %pep @ ep_back + @ .h 3 SPACES 
		." time : " %pep @ ep_xclock+ + @ .h 3 SPACES
		%pep @ ep_error + @ IF
			CR 
			." error: " %pep @ ep_error + @ ?DUP IF $type  THEN
		THEN
		CR
		." p_obj: " %pep @ ep_proto_obj + @ .h 3 SPACES
		." nif  : " %pep @ ep_nif_received + @ .h 3 SPACES
		." hop  : " %pep @ ep_nexthop + @ .h 3 SPACES
		." len  : " %pep @ ep_len + @ .h 3 SPACES
		CR
		." dst  : " %pep @ ep_dst + .hwa
		." src  : " %pep @ ep_src + .hwa
		." type : " %pep @ ep_type + W@ .word 7 SPACES
		CR
		%pep @ ep_data + .ip   	
	;
./version081/tcp/proto.html0100777000000000000000000001045407300314372014461 0ustar rootroot COLDFORTH KERNEL

proto class

license

The proto task demux the packet, finds a proto object and invokes the :proto_demux word method. 

 
	$10 CONSTANT _#proto_head_num
	ram_variable _%proto_table _#proto_head_num CELLS ram_allot

	: proto_find ( protocol --addr|zero)
		_%proto_table _#proto_head_num demux_find
	;

	\ if you add two handlers for the same protocol the first will
	\ be used as the system will refuse to add the second.
	: proto_add ( object protocol -- $ )
		_%proto_table _#proto_head_num  demux_add 
	;

	: proto_release ( addr --)
		demux_release
	;

	: proto_remove ( protocol --)
		_%proto_table _#proto_head_num demux_remove
	;

linked_object class

	protected
	cell% instance_variable %%protocol_number
	cell% instance_variable %%installed
	public
	ram_variable %defined_protocols

		m: ( --)
			\ set to resonable values.
			\ Only usfull if someont writes a bad protocol
			\ object.
			0 %%installed !
			-1 %%protocol_number !
			this [parent] :construct
		; overrides :construct


		m: ( --)
			%%installed @ IF
				%%protocol_number @ proto_remove
			THEN
			this [parent] :destruct
		; overrides :destruct

		m: ( --addr)
			%defined_protocols
		; overrides :list_head


		\ used by the proto task to get rid of the packet.
		m: ( pep -- )
			kill_free_buffer
		; method :proto_demux


		\ if the interface requires byte swapping this word must
		\ be called to deal with the protocol. For machines to
		\ interract the byte order must be correct.
		m: ( pep -- )
			DROP
		; method :proto_host<>net

		\ to demux a icmp destination not reached message
		m: ( pep --)
			kill_free_buffer
		; method :proto_error

		\ There are protocols that require checksumming
		\ after the source ip address is known.
		\ The source ip address should be determined by 
		\ the interface over which the packet is sent.
		\ As routing tables can change this is not known until
		\ the packet is routed.
		\ Instead of guessing the source ip address we provide
		\ the procol object and the interface calls :proto_checksun
		\ when doing the ip checksum
		m: ( pep --)
			DROP
		; method :proto_checksum
				
		\ allows user to see if the protocol was successfully installed
		m: ( --value)
			%%installed @
		; method :installed

		m: ( indent --)
			CR DUP SPACES ." protocol | " ." Object: " this .h  
			DROP send
		; overrides :print

end_class protocol

Word used in the proto task. The route task deals with all datagrams the proto task only deals with datagrams destined to the local machine.

Note we don't test for zero dequeue, we assume we got called with an item on the queue. 

 
	: proto_demux_ip_packet ( --)
		_proto_queue dequeue
		\ pep(--
		\ set the ipdata and ipcount fields
		\ setting them here means they can be used in all local code.
		DUP  _pep>ip_data_length OVER ep_ipcount + !
		DUP  _pep>ipdata OVER ep_ipdata + !

		DUP [ ep_data ip_proto + ]T LITERAL + B@ proto_find DUP IF
			\ pep addr (--
			\ We do the proto network to host swap here as this is the first place where
			\ the protocol has been demuxed.
			\ 2DUP :proto_host<>net                                                                                                    
			TUCK _#demux_bucket_object + @ :proto_demux
			proto_release
			EXIT
		THEN
		\ pep zero(--
		DROP
		\ the protocol is unreachable
		\ send an error message and return the 
		_#icc_proto_unreached SWAP icmp_error_message
	;

Print out a list of the installed protocols 

 
	: .protocols ( --)
			zero 
			CR DUP SPACES ." Protocol Objects"
			%defined_protocols
			BEGIN
				@ DUP
			WHILE
				\ offset list(--
				OVER 4 +
				OVER link>object DUP this <> IF
					\ offset list offset+8 object(--
					:print
				ELSE
					2DROP
				THEN
				\ offset list
			REPEAT
			\ offset zero(--
			2DROP
	;
./version081/tcp/routing.html0100777000000000000000000003321707300314372015007 0ustar rootroot COLDFORTH KERNEL license

This code is ran by a task it takes peps from the _ip_queue works out the interface to send the packet to and gets rid of it by calling :ip_consume for that interface. The word that does the job is rtget.

RFC1812
E.3.3 The OSPF Algorithm

OSPF uses an algorithm that is virtually identical to the Router Requirements Algorithm except for one crucial difference: OSPF considers OSPF route classes. 

      The algorithm is:

      1.  Basic match
      2.  OSPF route class
      3.  Longest match
      4.  Weak TOS
      5.  Best metric
      6.  Policy

The basic match is the first test. Zero TOS has lower prority than other types. If the type of service is non zero there has to be an exact match. The sort_key encodes starting from highest bits. OSPF route class ( called how), longest match ( most bits in mask).,and tos. The sort key determines link order, it dosn't have to be generated for a routing.

After how, number of bits and tos the policy is determined by the link order, last linked in is the one used 

 
	\ routing task action words


	\ count the number of bits in the mask
	: _ip_bits_set ( x -- n )
		zero
		IP_ALEN_BITS 0 DO
 			OVER 01 AND +
			SWAP
			2/
			SWAP
		LOOP
		NIP
	;

	: _make_sort_key { variable %mask
	                  variable %tos
	                  variable %how 
					  variable %metric -- ( key ) }
		%how @ 8 LSHIFT
		%mask @ _ip_bits_set OR 8 LSHIFT
		%tos @ OR 8 LSHIFT
		\ lower is better link is from highest to lowerest
		%metric @ $FF SWAP - OR
	;
	
	\ fields in sort key that have to be same for match to be found
	\ The metric part of the key is irrelevent for a match.
	$FFFFFF00 CONSTANT RT_SK_SAME_MASK

	\ we hash on the destination only.				
	: _ip>hash  { ( ip_addr mask  -- hash ) }{
		variable %network }
		AND %network !
		%network 4 
		\ checksum gives a nice flat distribution for most data
		checksum
		RT_TSIZE_MASK AND
	;



	\ it is a match if destination match and tos requirments are met.
	: _net_match { variable %route variable %dst variable %tos -- ( flag ) }
		%route @ rt_mask + @ %dst @  AND
		%route @ rt_net  + @ 
		= not IF
			FALSE EXIT
		THEN
		\ if tos of service for route is zero then route is ok
		%route @ rt_tos + @ 
		not IF
			TRUE EXIT						
		THEN
		\ route is only acceptable now it tos match
		%route @ rt_tos + @ %tos @ =
	;

	\ route cannot be used if has timed out or it's distance is way too large.
	: _valid_route? ( route --flag )
		DUP rt_ttl + @ xclock- @ + 0> 
		OVER rt_forever + @ OR IF
			\ we match the route
			\ The destination is reachable
			DUP rt_metric + @ RTM_INF < IF
				DROP			
				TRUE EXIT
			THEN
		THEN
		DROP
		FALSE
	;

	
	\ route_free - remove a route reference 
	\ The refcnt is set to one in route_add, it is reset in rttimer. _rt_record_get increments
	\ the count and as you can see _route_free decrements it. The routing words
	\ are written so that the routing tables are a resource that can be shared
	\ without claiming. 
	: route_free ( route --)
		-1 OVER rt_refcnt + +!
		DUP rt_refcnt + @ 1 < IF
			DUP unlink_double
			DUP kill_free_buffer
		THEN
		DROP
	;

	
	\ given a destination and tos return a route record.
	: route_get { variable %dst variable %tos -- ( route_entry|0 ) }
		\ get the list head.
		%dst @ 
		DUP ip>default_mask _ip>hash 
		%rttable +
		\ list(--
		BEGIN
			@ ?DUP 
		WHILE
			\ Done in most likely to fail order
			\ match desired address
			DUP %dst @ %tos @ _net_match 
			IF
				\ entry has still got time to live
				DUP _valid_route? IF
					1 OVER rt_refcnt + +!
					1 OVER rt_usecnt + +!
					EXIT
				THEN
			THEN
		REPEAT
		\ go for the default route
		\ Note there can be multiple default routes for different 
		\ service types. Allowing only one default route record 
		\ is not an option if your providing different types of services.
		0 0  _ip>hash 
		%rttable +
		BEGIN
			@ ?DUP 
		WHILE
			\ Done in most likely to fail order
			\ match desired address
			DUP %dst @ %tos @ _net_match IF
				\ entry has still got time to live
				DUP _valid_route? IF
					1 OVER rt_refcnt + +!
					1 OVER rt_usecnt + +!
					EXIT
				THEN
			THEN
		REPEAT
		\ destination cannot be reached
		zero
	;

	\ icmp requires us to return a route for returned datagram.
	\ we need to be able to extract the route using the ip base
	\ address
	: _ip_route_get ( ip -- route_entry|0 ) 
		\ ip(--
		DUP ip_dst + @
		SWAP _ip>ip_tos
		route_get
	;

	\ this looks for a record that can be used to route the packet
	\ remember after you do a route_get you have to do a route_free
	\ This is the word that has to be executed to route a packet.
	\ I think, by any standard it is resonable tight code.
	\
	\ By using a seperate search for the route with no mask ( the default)
	\ the default route can be treated like any other and there is 
	\ no default route to maintain.
	: _pep_route_get ( pep -- route_entry|0 )
		ep_data + _ip_route_get
	;

	\ This looks for a particular record
	\ remember after you do a _rt_record_get you have to do a route_free
	
	\ how, mask_bit_lengths, tos, and metric are included in the hash value.
	\ Records with same gateway, same how, same mask_bit_length and same tos 
	\ are the same. We therefor need to remove the metric from the sort key.
	\ This is done in rt_record.

	: _rt_record_get {	
	          variable %net
			  variable %gw
			  variable %mask 
			  variable %tos
			  variable %how 
			  -- ( addr ) }{
			  variable %sort_key }
		\ mask tos how and metric are hashed into the sort_key
		\ If all but the metric is the same then this is the record.
		%mask @ %tos @ %how @ zero _make_sort_key RT_SK_SAME_MASK AND %sort_key !
		%net @ DUP ip>default_mask _ip>hash 
		%rttable +
		BEGIN
			@ ?DUP 
		WHILE
			DUP rt_net + @ %net @ = IF
				DUP rt_gw + @ %gw @ = IF 
					DUP rt_sort + @ RT_SK_SAME_MASK AND %sort_key @ = IF
						\ The mask should be contiguous bits in the left
						\ of the mask, so equality of the sort key should be it
						\ but to allow for crazy masks we have to do
						\ a mask compare
						DUP rt_mask + @ %mask @ = IF
							\ add to reference count
							\ have to use _route_free when finished
							\ with _rt_record_get
							1 OVER rt_refcnt + +!
							EXIT						
						THEN
					THEN
				THEN
			THEN
		REPEAT
		zero
	;


	: _find_link_position ( key head -- head )
		BEGIN
			DUP @
		WHILE
			DUP @ rt_sort +  @ 
			\ key link test_key(--
			jump > not IF
				NIP
				EXIT
			THEN
			@
		REPEAT
		NIP
	;

	: _link_in_route_record { variable %rt_record -- }

		\ The position to link in the list is dependent on the sort key
		%rt_record @ rt_mask + @
		%rt_record @ rt_tos + @
		%rt_record @ rt_how + @
		%rt_record @ rt_metric + @ _make_sort_key
		DUP %rt_record @ rt_sort + ! 

		\ the list to link into is dependent on the destination
		%rt_record @ rt_net + @ 
		DUP ip>default_mask
		_ip>hash %rttable +
		\ head (--
 
		\ trace down list until sortkey less
		\ the masks with more bits are at the start of the list
	
		_find_link_position
		%rt_record @ SWAP link_double
	;


	\ remember our promise to the timer task; we will not delete
	\ routing table records.

	\ how, mask_bit_lengths, tos, and metric are included in the hash value.
	\ Records with same gateway, same how, same mask_bit_length and same tos 
	\ are the same. We therefor need to remove the metric from the sort key.
	\ This is done in rt_record.

	: route_add { variable %net 
	          variable %mask 
	          variable %gw 
	          variable %metric
			  variable %tos
			  variable %interface 
			  variable %ttl
			  variable %how 
			  variable %broadcast ( -- $ ) }{
			  variable %rt_record }
		%net @ %gw @ %mask @ %tos @ %how @ _rt_record_get %rt_record !

		\ If %rt_record is not zero everything is the same except the metric
		\ which may be the same.

		%rt_record @ 
		IF
			%rt_record @ rt_metric + @ %metric @ <> IF	
				\ we have to unlink update metric
				\ and relink
				%rt_record @ unlink_double
				%metric @ %rt_record @ rt_metric + !
				%rt_record @ _link_in_route_record
			THEN
			\ decrement count increased by _rt_record_get
			%rt_record @ route_free
			zero
			EXIT
		THEN

		\ (--
		\ It is a new route
		\ Note we don't just keep the best route, we keep all with
		\ the timeout routine removing them. They are kept in sorted order 
		\ from best to worse. So if the timer routine removes a good route we 
		\ just fall back to the not so good.
		rt_length ['] get_free_buffer CATCH ?DUP IF
			\ just smile
			NIP \ get rid of length
			EXIT
		THEN
		%rt_record !
		\ (--
		%rt_record @ rt_length ERASE

		%broadcast @ %rt_record @ rt_broadcast + !
		%net @ %rt_record @ rt_net + !
		%mask @ %rt_record @ rt_mask + !
		%gw @ %rt_record @ rt_gw + !
		%metric @ %rt_record @ rt_metric + !
		%tos @ %rt_record @ rt_tos + !
		%interface @ %rt_record @ rt_interface + !
		%ttl @ xclock+ @ + %rt_record @ rt_ttl + !
		%ttl @ RT_INF = IF
			TRUE %rt_record @ rt_forever + !
		THEN
		%how @ %rt_record @ rt_how + !
		\ this will be decremented when the timer
		\ routine releases the route. Up until then it prevents
		\ others from deleting it.

		1 %rt_record @ rt_refcnt + +!
		
		\ (--
		%rt_record  @  _link_in_route_record 
		
		\ (--
		zero
	;


	: static_route ( net mask gw metric tos interface--)
		RT_INF RT_STATIC FALSE route_add $ABORT
	;

	: broadcast_route ( net mask gw metric tos interface--)
		RT_INF RT_STATIC TRUE route_add $ABORT
	;


	\ This word must take care rtget and rtadd are used in a high level tasks
	\ rttimer is a low level task. We must take care to keep
	\ the route table valid at all times. We are the only
	\ ones that can remove a route
	: _rttimer { ( --) }{
		variable %rip_notify
		}
		FALSE %rip_notify !
		[ RT_TSIZE 4* %rttable + ]T LITERAL %rttable DO
			\ (--
			I @ 
			BEGIN
				?DUP
			WHILE
				\ packet may begone by the REPEAT so get next address now
				DUP @ SWAP
				\ next_in_list list(--
				DUP rt_ttl + @ xclock- @ + 0> not OVER rt_forever + @ not AND IF
				\ route has timed out
					DUP rt_metric + @ RTM_INF < IF
						TRUE %rip_notify !
						\ destination cannot be reached
						RTM_INF OVER rt_metric + !
						\ route lives for a while
						xclock+ @ RIPZTIME + OVER rt_ttl + !
					ELSE
						\ the second timeout has occured. Time
						\ to delete. The delete will not occure
						\ if rt_refcnt is greater than zero.
						\ Next time around another attempt to 
						\ delete will occure.
						\ This descrements the count set in rt_add
						\ if somone is using the entry it will be
						\ that someone that releases the packet.
						DUP route_free
					THEN
				THEN
				DROP
			REPEAT
			xpause
		cell +LOOP

\		%rip_notify @ IF
\			_lock_word
\			%rip_activation @ IF
\				wake %rip_activation @ !
\				zero %rip_activation !
\			THEN
\			_unlock_word
\		THEN

	;

This is the word executed by the route task. It waits for a packet on the ip queue, finds a route, if found it calls :consume_interface to get rid of the packet and that is it. 

 
	ram_variable %no_route_discards
	
	: _route_ip_packet ( --)
		_ip_queue dequeue ?DUP IF
			\ pep(--
			DUP _pep_route_get ?DUP IF
				\ pep route(--
				\ The nexthop address determines the box we sent the
				\ datgram to; if there is no gateway entry then we 
				\ want to send it to the datagram destination.
				2DUP rt_gw + @ 
				\ pep route pep gw(--
				?DUP IF
					\ pep route pep gw(--
					SWAP ep_nexthop + !
				ELSE
					 \ pep route pep (--
					 DUP  [ ep_data ip_dst + ]T LITERAL + @
					 SWAP ep_nexthop + !
				THEN 
				\ pep route(--
				\ ttl is decremented in interface if not zero;
				\ routing sets to route ttl if
				\ not less than RTM_INF.
				\ Interface sending to wire will discard datagram that does not 
				\ have a ttl value greater than zero.
				\ A received datagram with zero ttl will be received locally but
				\ will not be passed on.
				OVER [ ep_data ip_ttl + ]T LITERAL + B@ RTM_INF < not IF
					\ pep route(--
					2DUP rt_metric + @ SWAP [ ep_data ip_ttl + ]T LITERAL + B!
				THEN
				\ pep route(--
				DUP rt_broadcast + @ 
				IF
					\ pep route(--
					DUP rt_interface + @ 
					SWAP route_free
					:broadcast
				ELSE
					DUP rt_interface + @
					SWAP route_free 
					:consume_interface
				THEN
			ELSE
				\ pep(--
				\ no route
				1 %no_route_discards +!
				\ if a local datagram the source has to be set to local 
				\ machine. This will be swapped icmp_error and become the
				\ destination of the error message.
				DUP [ ep_data ip_src + ]T LITERAL + @ not IF
					127.000.000.000 OVER [ ep_data ip_src + ]T LITERAL + !
					\ There sould be a gateway to send messades to; if 
					\ a local message ends up here; this is a resonable 
					\ conclusion.
					_#icc_scr_host_isolated SWAP icmp_routing_error
					EXIT
				THEN	 
				_#icc_net_unreached SWAP icmp_routing_error
			THEN
		THEN
	;
./version081/tcp/routing_h.html0100777000000000000000000000473007300314372015314 0ustar rootroot COLDFORTH KERNEL
route.h - RTFREE
license 
 
\ how routing table entries were generate, high numbers will have precedence over
\ over lower
0 CONSTANT RT_STATIC
1 CONSTANT RT_ICC_REDIRECT

\ Routing Table Entries:
\ struct route 
	zero
	DUP CONSTANT rt_link      CELL+
	DUP CONSTANT rt_link_back CELL+
	DUP CONSTANT rt_net       IP_ALEN +      \ network address for this route
	DUP CONSTANT rt_mask      IP_ALEN +      \ mask for this route
	DUP CONSTANT rt_sort      CELL+          \ number of bits set in mask
	DUP CONSTANT rt_how       CELL+          \ how the key was added
	DUP CONSTANT rt_tos       CELL+          \ type of service offered by route
	DUP CONSTANT rt_gw        IP_ALEN +      \ next IP hop
	DUP CONSTANT rt_metric    CELL+          \ distance metric
	DUP CONSTANT rt_interface CELL+          \ interface object to send data our on
	DUP CONSTANT rt_ttl       CELL+          \ time to live
	DUP CONSTANT rt_forever   CELL+          \ set to true if route to last forever
	DUP CONSTANT rt_broadcast CELL+          \ true if local machine to treat as a broadcast
	DUP CONSTANT rt_refcnt    CELL+          \ current reference count
	DUP CONSTANT rt_usecnt    CELL+          \ total use count so far
		CONSTANT rt_length  

ip_anyaddr  CONSTANT RT_DEFAULT              \ the default net
ip_loopback CONSTANT RT_LOOPBACK             \ the loopback net

\ must be a binary power
$80         CONSTANT RT_TSIZE               \ these are pointers to lists
RT_TSIZE 1 - CELLS 
            CONSTANT RT_TSIZE_MASK           \ mask used to select rttable offset
#999        CONSTANT RT_INF                  \ no timeout for this route

01          CONSTANT #ttl_local_net
RFC1700 page 63

The current recommended default time to live (TTL) for the Internet Protocol (IP) [45,105] is 64. 

 
$41         CONSTANT RTM_INF                 \ an infinite metric

#120 #1sec * CONSTANT RIPZTIME 

ram_variable %rttable RT_TSIZE CELLS ram_allot

\ points to a route packet.
ram_variable %default_route
./version081/tcp/rpc.html0100777000000000000000000006230207300314372014101 0ustar rootroot RPC RFC1014 XDR
RFC1057 RPC
RFC1094 NFS

Three spec looks hard doesn't it. RFC1014 describes a method to describe data, nothing more. RFC1057 describes a data structure to send for a RPC and the reply to expect. RFC1094 describes the functions available for NFS.

It is almost as if sun went to great lengths to hide the elegent simplicity of NFS.

The mount class

In this OS you only use mount to mount a remote file system. mount machine/file creates an object. The mounting precess need rfc, rfc needs the mount object so we start off with null methods and then flesh it out after the rfc code has been defined. 

 
	#32 CONSTANT _#fh_size
	ram_variable %rpc_debug
	object class
		\ the mount machine as a number
		cell% instance_variable %%mount_machine
		\ the mount machine as a string
		cell% instance_variable %%mount_machine$>
		\ the nfs handle we have to use to access the file system
		cell% instance_variable %%nfs_handle
		\ the file handle we have to supply to the remote device.
		_#fh_size bytes% instance_variable %%fh_mount
		m: ( -- ip)
			%%mount_machine @
		; method :mount_ip
		
		m: ( -- addr)
			%%mount_machine$> @
		; method :$mount_ip

		m: ( --handle)
			%%nfs_handle @
		; method :nfs_handle


		m: ( --fhandle)
			%%fh_mount
		; method :nfs_fhandle

		m: ( indent --)
			CR DUP SPACES ." _mount_class | " ." Object: " this .h  
			DROP send
		; overrides :print

	end_class _mount_class
		 	
	uvariable %mount_object
The request
 
\ describe constant part of rpc header
\ we use 4 not cell as this is defined in rfc1057
zero 
DUP	CONSTANT	_#rpcc_xid          4+
DUP	CONSTANT	_#rpcc_code         4+  \ = zero for call
DUP	CONSTANT	_#rpcc_rpc_version  4+  \ RPC1057 page 10 The version of the rpc spec, must equal 2
DUP	CONSTANT	_#rpcc_program      4+  \
DUP	CONSTANT	_#rpcc_version      4+
DUP	CONSTANT	_#rpcc_procedure    4+
DUP	CONSTANT	_#rpcc_cred_flavour 4+
\ RFC1057 page 6 opague<400>
\ RFC1014 page 8 opague starts with a 4 byte count and is followed by the data.
DUP	CONSTANT	_#rpcc_cred_length  4+
DUP CONSTANT    _#rpcc_cred_data    4+
DROP

\ define the verf header
zero
DUP CONSTANT	_#rpcc_verf_flavour 4+
DUP	CONSTANT	_#rpcc_verf_length  4+
DUP CONSTANT	_#rpcc_verf_data    4+
DROP

\ xdr_aligned
\ all data must be on 4 byte boundries
: xdr_aligned ( valuein -- valueut)
	3 + -4 AND 
;

\ If archetecture is little edian these would be a little more complex.
\ they should be used for portability.

\ xdr data fetch
: x@ @ ; inline

\ xdr data store
: x! ! ; inline

\ get the base address verf, this follows the cred. 
\ A count field in the cred determines how long it is.
: _rpcc_verf ( udp_data -- verf_base )
	DUP _#rpcc_cred_length + x@ \ addr count(--
	xdr_aligned +            \ addr(--
	_#rpcc_cred_data +         \ addr(--
;

: _rpcc_parameters ( udp_data -- parameters)
	_rpcc_verf
	DUP _#rpcc_verf_length + @ + 
	_#rpcc_verf_data + @
;
The responce
 
zero
DUP	CONSTANT	_#rpcr_xid	 4+     \ equals xid sent
DUP	CONSTANT	_#rpcr_code	 4+		\ Must be a 1
DUP	CONSTANT	_#rpcr_status 4+	\ MSG_ACCEPTED or MSG_DENIED

\ following is for case where status is zero ( MSG_ACCEPTED )
DUP	CONSTANT	_#rpcr0_verf_flavour	4+
DUP	CONSTANT	_#rpcr0_verf_length	4+
DUP	CONSTANT	_#rpcr0_verf_data	4+
DROP

\ following is for the rejected reply ( MSG_DENIED)
_#rpcr_status	4+
DUP	CONSTANT	_#rpcr1_reject_status	4+ \ RPC_MISMATCH, AUTH ERROR
DUP	CONSTANT	_#rpcr1_reject_data
DROP
\ following is for rpc_mismatch ( rpc version not = 2)
_#rpcr1_reject_data 4+
DUP CONSTANT	_#rpcr10_data_low	4+
DUP	CONSTANT	_#rpcr10_data_high 4+
DROP
\ folowing is for auth_error
_#rpcr1_reject_data 4+
DUP	CONSTANT	_#rpcr11_auth_stat \ AUTH_BADCRED,AUTH_REJECTEDCRED,AUTH_BADVERF etc.
DROP
msg_type

Send to the server as a call, you will get back a reply, RFC1057 page 8

 
zero
DUP CONSTANT	_#rpc_call 1+
	CONSTANT	_#rpc_reply
reply_stat

Rejected if authentication is bad, or if version number not 2, RFC1057 page 8

 
zero
DUP	CONSTANT	_#rpc_msg_accepted 1+
	CONSTANT	_#rpc_msg_denied
reject_stat

Why this field was not combined with the previous beats me, but this is the way it is speced. If the reply_stat equals _#rpc_msg_denied, it is followed by a field that gives a reason. 

 
zero
DUP CONSTANT	_#rpc_reject_version 1+
	CONSTANT    _#rpc_reject_auth
accept_state

If the call was accepted ( authentication ok and version ok), the call can still be in error, this field is used to return the error, it is located after the verf

 

\ accept codes
zero
DUP CONSTANT	_#rpc_accept_success 1+
DUP CONSTANT	_#rpc_accept_prog_unavail 1+
DUP CONSTANT	_#rpc_accept_prog_mismatch 1+
DUP CONSTANT	_#rpc_accept_proc_unavail 1+
DUP CONSTANT	_#rpc_acceptgarbage_args 1+
DROP

\ auth codes
zero
DUP	CONSTANT	_#auth_null 1+
DUP	CONSTANT	_#auth_unix 1+
DUP	CONSTANT	_#auth_short 1+
DUP	CONSTANT	_#auth_des 1+
DROP


2 CONSTANT _#rpc_version_code

\ resons why authentication can fail
CREATE $auth_buggered        ," RPC auth failed unknown reason"
CREATE $auth_badcred         ," RPC auth failed bad credentials (seal broken)"
CREATE $auth_rejectedcred    ," RPC auth failed client must begin new session"
CREATE $auth_badverf         ," RPC auth failed bad verifier (seal broken)"
CREATE $auth_rejectedverf    ," RPC auth failed verifier expired or replayed"
CREATE $auth_tooweak         ," RPC auth failed rejected for security reasons"

CREATE _auth_fail
	7 tw,
	$auth_buggered       t,
	$auth_badcred        t,
	$auth_rejectedcred   t,
	$auth_badverf        t,
	$auth_rejectedverf   t,
	$auth_tooweak        t,
	$auth_buggered       t,

\ desctibe the above table
zero
DUP	CONSTANT	_#tbl_count	2+
	CONSTANT	_#tbl_data

: _auth_fail$ ( code -- addr )
	_auth_fail _#tbl_count + W@ MIN 
	zero MAX
	CELLS _auth_fail + _#tbl_data + @
;

CREATE	$accept??           ," RPC call failed for unknown reasons"
CREATE	$accept_prog??      ," RPC call failed program not available"
CREATE  $accept_version??   ," RPC call failed version not available"
CREATE	$accept_procedure?? ," RPC call failed no precedure"
CREATE  $accept_arguments?? ," RPC call failed bad arguments"

CREATE _accept_fail
		6 tw,
		$accept??           t,
		$accept_prog??      t,
		$accept_version??   t,
		$accept_procedure?? t,
		$accept_arguments?? t,
		$accept??           t,

An accepted call can still fail. The accept status can take many non zero values that represent errors. This word converts those values into the address of a string describing the problem. 

  
: _accept_fail$ ( code -- $ )
	_accept_fail _#tbl_count + W@ MIN 
	zero MAX
	CELLS _accept_fail + _#tbl_data + @
;

addr_in is the base address of the data area addr_out is the address of the accept_status cell. 

 
: _rpcr_accept_status ( addr -- addr )
	DUP _#rpcr0_verf_length + @ xdr_aligned + 
	_#rpcr0_verf_data +
;

: _rpcr_parameters ( udp_data -- param_addr)
	_rpcr_accept_status
	4+
;

ABORTS if all is not OK. Flag is true if the reply is for the message sent, false if it is not related. 

 
: _reply_ok ( pep_sent pep_reply --flag)
	ep_protodata + @  \ pep_send udp_reply(--
	SWAP
	ep_protodata + @
	SWAP              
	\ udp_send udp_reply(--
	OVER _#rpcc_xid + x@ OVER _#rpcr_xid + x@ <> IF
		\ this may be a valid result, just isn't the right one.
		\ remember we can get duplicate datagrams
		2DROP FALSE
		EXIT
	THEN
	NIP
	\ udp_reply(--
	DUP _#rpcr_code + x@ _#rpc_reply <> ABORT" RPC call code was not a reply"
	\ udp_reply(--
	DUP _#rpcr_status + x@ _#rpc_msg_accepted <> IF
		DUP _#rpcr_status + x@ _#rpc_msg_denied = IF
			DUP _#rpcr1_reject_status + x@ _#rpc_reject_version 
			= ABORT" RPC version number wrong"
			DUP _#rpcr1_reject_status + x@ _#rpc_reject_auth = IF
				_#rpcr11_auth_stat + x@ _auth_fail$ 
				$ABORT
			THEN
			\ status value unknown  
			TRUE ABORT" RPC call reject status value out of range"
		THEN
		TRUE ABORT" RPC call status value out of range"
	THEN
	\ ok move onto accept status, this is after the verifier
	_rpcr_accept_status
	x@ DUP _#rpc_accept_success <> IF
		_accept_fail$ $ABORT
	THEN
	DROP
	TRUE
;

%xid just rotates. It is expected the call packet is only made once. This means the higher code must copy the call packet as the call could timeout and have to be resent. 

 

	: nfs_name  ( -- addr n ) 
			S" 192.168.255.1" 

\		%mount_object @ ?DUP IF
\			 :$mount_ip COUNT
\		ELSE
\			TRUE ABORT" Remote files system must be mounted"
\		THEN 
	;

	: nfs_ip ( -- ip)
		%mount_object @ ?DUP IF
			:mount_ip 
		ELSE
			TRUE ABORT" Remote file system must be mounted"
		THEN
	;
	
CREATE _default_unix
	$00000018 t,  \ length
	$00000001 t,  \ stamp
	$00000004 t,  \ count
	$7261636B t,  \ rack
	$00000000 t,  \ uid
	$00000000 t,  \ gid
	$00000000 t,  \ gid count
	 
: _auth_unix { variable %addr -- }
	%mount_object @ IF
		\ stamp
		zero %addr @ !	4 %addr +!
		\ machine name
		nfs_name  \ Saddr num (--
		\ count
		DUP %addr @ ! 4 %addr +!
		%addr @ OVER xdr_aligned %addr +!
		SWAP MOVE
		\ uid
		zero %addr @ ! 4 %addr +!
		\ gid
			zero %addr @ ! 4 %addr +!
		\ gids
		zero %addr @ !
	ELSE
		_default_unix 4+ %addr @ _default_unix @ MOVE
	THEN
;

: _auth_unix_length ( -- num )
	%mount_object @ IF
		nfs_name NIP xdr_aligned
		\ stamp, string count, uid, gid, gids count
		$14 +
	ELSE
		_default_unix @
	THEN  
;


	ram_variable %xid
	
: _setup_rpc_head ( program version proc pep_in -- addr_parameters )
	[ _#rpcc_cred_data _#rpcc_verf_data + ]T LITERAL 
	_auth_unix_length +
	OVER add_to_udp
	ep_protodata + @
	_lock_word
	%xid @	1 %xid +!
	_unlock_word
	\ stuff program version proc pep_in xid(--
	OVER _#rpcc_xid + x!
	\ stuff program version proc addr_in(--
	_#rpc_call OVER _#rpcc_code + x!
	_#rpc_version_code OVER _#rpcc_rpc_version + x!
	SWAP OVER _#rpcc_procedure + x!
	SWAP OVER _#rpcc_version + x!
	SWAP OVER _#rpcc_program + x!
	_auth_unix_length IF
		_#auth_unix OVER _#rpcc_cred_flavour + !
	ELSE
		_#auth_null OVER _#rpcc_cred_flavour + !
	THEN
	_auth_unix_length OVER _#rpcc_cred_length + !
	DUP _#rpcc_cred_data + _auth_unix
	\ stuff addr1(--
	_rpcc_verf
	\ stuff addr2(--
	_#auth_null OVER _#rpcc_verf_flavour + !
	zero OVER _#rpcc_verf_length + ! 	
	_#rpcc_verf_data +
;

n is the number of parameters

 

: _rpc_packet { ( data_size program version proc ) variable %handle  -- ( parameters pep ) }{
	variable %pep }
	\ have to get n, oh well as much as I hate ROLL
	3 ROLL
	ep_data +
	ip_options + 
	udp_data +
	 _#rpcc_cred_data +
	 _auth_unix_length +
	 _#rpcc_verf_data +
	get_free_buffer
	\ stuff version proc addr(--
	%pep !
	%pep @ %handle @ :setup_protocol
	%pep @ _setup_rpc_head
	%pep @
;

\ we don't send another unless we timeout waiting for a reply.
\ or we have received a reply. It is therefor acceptable to
\ force the datagram onto the queue.
: _send_datagram ( pep --) 
	queue_ip_force
;

\ this can abort	
: _receive_datagram ( handle -- pep2)
	:read_protocol
	2DROP
;

The input pep is consumed. We return a pep otherwise input stack has to describe how to unpack the parameters. The unpack could depend on reply values so it is just not worth this word getting involved.

It is a linear backoff, see code below. You have to remember that RPC is intended for local networks. Comms failures are not common, but connecting to wrong machine is. 




\ we are responsible for the returning of pep_in	
: _rpc_call { ( pep_in handle)  -- ( pep_out|zero)  }{
	\ number of times we have resent _rpc datagram
	variable %tries 
	\ if your not happy with rpc efforts to get through ajust these.
	05  CONSTANT _#max_tries
	#20 CONSTANT _#rpc_timeout \ 200 msec is enough
	 }
	_#rpc_timeout OVER :!timeout
	zero %tries !
	BEGIN
		%rpc_debug @ IF
			.S ." pep handle(-- Sending rpc_request"
		THEN
		\ pep handle(--
		OVER 
		_clone_datagram DUP IF
			\ pep_in handle pep(--
			_send_datagram
			\ pep_in handle(--
			DUP ['] _receive_datagram CATCH ?DUP IF
				\ the receive aborted
				\ pep_in handle handle $(--
				>R
				2DROP
				kill_free_buffer
				R>
				%rpc_debug @ IF
					.S ." $(--failed to read reply datagram"
				THEN
				$ABORT
			THEN
			%rpc_debug @ IF
				.S ." pep_in handle pep_out(--received rpc reply" 
			THEN
			\ pep_in handle  pep_out(--
			\ pep_out will be zero if timeout
			?DUP IF
				\ pep_in handle pep_out(--
				jump OVER 
				\ pep_in handle pep_out pep_in pep_out(--
				\ will abort for many reasons related to returned data
				['] _reply_ok CATCH ?DUP IF
					%rpc_debug @ IF
						.S ." pep_in handle pep_out ? ? $(--failed dismally" 
					THEN
					\ abort message to stack
					>R
					\ parameters that where to be used by _reply_ok
					2DROP
					\ pep_in handle pep_out(--
					kill_free_buffer
					\ pep_in handle(--
					DROP 
					\ pep_in(--
					kill_free_buffer
					R>
					\ closing the handle is someone elses problem 
					$ABORT
				THEN
				\ pep_in handle pep_out flag(--
				IF
					\ reply ok
					%rpc_debug @ IF
						.S ." pep_in handle pep_out(--reply ok" 
					THEN

					\ pep_in handle pep_out(--
					>R 
					DROP
					\ pep_in(--
					kill_free_buffer
					R>
					EXIT
				THEN
				%rpc_debug @ IF
					.S ." pep_in handle pep_out(--irrelevent reply" 
				THEN

				\ we get here if the reply was irrelevent
				\ pep_in handle pep_out(--
				kill_free_buffer
			ELSE
				%rpc_debug @ IF
						.S ." pep_in handle(--udp receive timeout" 
				THEN
			THEN
			\ pep_in handle(--
			\ ok what happens if it fails forever
			1 %tries +!
			\ add a little more.
			DUP :@timeout _#rpc_timeout + OVER :!timeout
			%tries @ _#max_tries > IF
				DROP 
				kill_free_buffer
				zero EXIT
			THEN
		ELSE
			%rpc_debug @ IF
					.S ." pep_in handle(--not enough memeory" 
			THEN
			\ pep_in handle(--
			\ not enough free memory
			DROP
			kill_free_buffer
			zero EXIT
		THEN
	AGAIN
	;

	cell 4 ??= 

	\ This is a shit of a word, breaks all good coding rules.
	\ Makes assumptions on stack direction cell size, and assumes
	\ the stack can be read as normal memory. But the parameters
	\ are stored in order.
	: _move_parameters {  ( parameters ) variable %n variable %to_addr --  }{
		variable %from_addr }
		\ [parameters] (-- 
		@s %n @ 1- 4* +  %from_addr !
		\ [parameters] base_addr(--
		%n @ zero ?DO
			%from_addr @ @
			%to_addr @ !
			4 %to_addr +!
			-4 %from_addr +!
		LOOP
		\ drop n parameters
		@s %n @ 4* + !s
	;

	: _data_to_stack ( addr n -- data cells)
		xdr_aligned 
		\ number of cells put on stack
		DUP 4/ >R
		zero ?DO
			DUP I + @ SWAP
		4 +LOOP
		DROP
		R>
	;

	: _string_to_stack ( addr n -- length ?? n)
		SWAP OVER _data_to_stack 1+
	;

The base rpc takes a number of parameters from the stack, first on top creates a packet for the parameters, gets a reply pep and returns it. The structure of this work makes it quite clear how you would create other words to setup the input parameters in any manner desired. 

 
: _rpc ( parameters n  program version proc handle -- reply_rpc|zero )
	2>R 2>R
	DUP 4* \ the paremeters size is determined by the protocol spec
	2R> 2R> 
	\ save handle on return stack
	DUP >R
	\ paramerters n size program version proc handle(--
	_rpc_packet 
	\ parameters n parameters_addr pep (--
	\ lets write this so you put the parameters on the stack 
	\ in order documented in C function descriptions
	>R
	\ parameters n addr(--
	OVER 4* >R
	_move_parameters
	\ add to the udp_datagram
	2R>
	OVER add_to_udp
	\ pep (--
	R>
	\ pep handle(--
	_rpc_call
;


: _rpc+nfsdata { ( parameters n addr n  program version proc handle 
                  -- reply_rpc|zero ) }{
				  variable %addr 
				  variable %n
	              variable %pep
	              variable %parameters }
	2>R 2>R
	%n !
	%addr !
	\ parameters n(--
	DUP 4* %n @ xdr_aligned 4+ + \ 
	2R> 2R> 
	\ save handle on return stack
	DUP >R
	\ paramerters n size program version proc handle(--
	_rpc_packet 
	%pep ! %parameters !
	\ parameters n(--
	\ lets write this so you put the parameters on the stack 
	\ in order documented in C function description
	\ parameters n addr(--
	%parameters @ OVER 4* >R
	_move_parameters
	\ add to the udp_datagram
	R@ %pep @ 
	add_to_udp
	R> %parameters +!
	\ (--
	%n @ xdr_aligned 4+ %pep @ 
	add_to_udp
	\ (--
	%n @ %parameters @ x!
	%addr @  %parameters @ 4+ %n @ MOVE
	%pep @ R>
	\ pep handle(--
	_rpc_call
;



	CREATE _uxFF ," Unknown unix error"
	CREATE _ux01 ," Operation not permitted"
	CREATE _ux02 ," No such file or directory"
	\ CREATE _ux03 ," No such process"
	\ CREATE _ux04 ," Interrupted system call"
	CREATE _ux05 ," I/O error"
	CREATE _ux06 ," No such device or address"
	\ CREATE _ux07 ," Arg list too long"
	\ CREATE _ux08 ," Exec format error"
	\ CREATE _ux09 ," Bad file number"
	\ CREATE _ux10 ," No child process"
	\ CREATE _ux11 ," Try again"
	\ CREATE _ux12 ," Out of memeory"
	CREATE _ux13 ," Permission denied"
	\ CREATE _ux14 ," Bad address"
	\ CREATE _ux15 ," Block device required"
	\ CREATE _ux16 ," Device or resource busy"
	CREATE _ux17 ," File exists"
	\ CREATE _ux18 ," Cross-device link"
	CREATE _ux19 ," No such device"
	CREATE _ux20 ," Not a directory"
	CREATE _ux21 ," Is a directory"
	\ CREATE _ux22 ," Invalid argument"
	\ CREATE _ux23 ," File table overflow"
	\ CREATE _ux24 ," Too many open files"
	\ CREATE _ux25 ," Not a printer"
	\ CREATE _ux26 ," Text file busy"
	CREATE _ux27 ," File too large"
	CREATE _ux28 ," No space left on device"
	\ CREATE _ux29 ," Illegal seek"
	CREATE _ux30 ," Read only file system"
	CREATE _ux63 ," Name too long"
	CREATE _ux66 ," Not empty"
	CREATE _ux69 ," Disk quota exceeded"
	CREATE _ux70 ," Fhandle not valid"
	CREATE _ux99 ," Cache flushed"
	
	CREATE _unix_errors
	 01 tw, _ux01 t,
	 02 tw, _ux02 t,
	 05 tw, _ux05 t,
	 06 tw, _ux06 t,
	 #13 tw, _ux13 t,
	 #17 tw, _ux17 t,
	 #19 tw, _ux19 t,
	 #20 tw, _ux20 t,
	 #21 tw, _ux21 t,
	 #27 tw, _ux27 t,
	 #28 tw, _ux28 t,
	 #30 tw, _ux30 t,
	 #63 tw, _ux63 t,
	 #66 tw, _ux66 t,
	 #69 tw, _ux69 t,
	 #70 tw, _ux70 t,
	 #99 tw, _ux99 t,
	 -1  tw, _uxFF t,

	: _unix_code>string { variable %code -- ( $ ) }{
		\ describe above table
		0 CONSTANT _#unix_error_code
		2 CONSTANT _#unix_error$
		6 CONSTANT _#unix_error_length
		}
		_unix_errors 
		BEGIN
			\ table terminator
			DUP _#unix_error_code + W@ $FFFF = IF
				_#unix_error$ + @
				EXIT
			THEN
			DUP _#unix_error_code + W@ %code @ = IF
				_#unix_error$ + @
				EXIT
			THEN
			_#unix_error_length +
		AGAIN
	;

NFS Mount

 
	

	#100003 CONSTANT _#nfs_program
	#2      CONSTANT _#nfs_version


	0 CONSTANT _#nfs_null
	1 CONSTANT _#nfs_getattr
	2 CONSTANT _#nfs_setattr
	3 CONSTANT _#nfs_root
	4 CONSTANT _#nfs_lookup
	5 CONSTANT _#nfs_readlink
	6 CONSTANT _#nfs_read
	7 CONSTANT _#nfs_writecache
	8 CONSTANT _#nfs_write
	9 CONSTANT _#nfs_create
	#10 CONSTANT _#nfs_remove
	#11 CONSTANT _#nfs_rename
	#12 CONSTANT _#nfs_link
	#13 CONSTANT _#nfs_symlink
	#14 CONSTANT _#nfs_mkdir
	#15 CONSTANT _#nfs_rmdir
	#16 CONSTANT _#nfs_readdir
	#17 CONSTANT _#nfs_statfs






	_mount_class class


		#100000 CONSTANT _#pm_program
		#2      CONSTANT _#pm_version

		\ the port mapper routines
		0 CONSTANT _#pm_null
		1 CONSTANT _#pm_set
		2 CONSTANT _#pm_unset
		3 CONSTANT _#pm_getport
		4 CONSTANT _#pm_list
		5 CONSTANT _#pm_callit

		#17     CONSTANT _#pm_udp
		#6      CONSTANT _#pm_tcp

	

		#100005 CONSTANT _#mountd_program
		#1      CONSTANT _#mountd_version

	
		\ mountd routines
		0 CONSTANT _#mountd_null
		1 CONSTANT _#mountd_mount
		2 CONSTANT _#mountd_dump
		3 CONSTANT _#mountd_umount
		4 CONSTANT _#mountd_umount_all
		5 CONSTANT _#mountd_export

	


		: _open_pm ( -- addr) 
			%%mount_machine @ #111 $" (udp_client)" zero $open
		;

		: _get_nfs_port { ( -- port) }{
			variable %pm_handle }
			_open_pm %pm_handle ! 
			%pm_handle @ not ABORT" Can't open port mapper"
			_#nfs_program _#nfs_version _#pm_udp 0 4 \ end of call parameters
			_#pm_program _#pm_version _#pm_getport %pm_handle @ _rpc
			%pm_handle @ close 
			?DUP IF  
				DUP ep_protodata + @ _rpcr_parameters @	
				SWAP  kill_free_buffer
			ELSE
				TRUE ABORT" port mapper not responding"
			THEN
		;				

		: _get_mountd_port { ( -- port) }{
			variable %pm_handle  }
			_open_pm %pm_handle !
			_#mountd_program _#mountd_version _#pm_udp 0 4 \ end of call parameters
			_#pm_program _#pm_version _#pm_getport %pm_handle @ _rpc 
			%pm_handle @ close
			?DUP IF  
				DUP ep_protodata + @ _rpcr_parameters x@
				SWAP 
				kill_free_buffer
			ELSE
				TRUE ABORT" port mapper not responding"
			THEN 
		;


		: _open_mountd ( -- addr)
			%%mount_machine @ _get_mountd_port $" (udp_client)" zero $open
		;

		: _mount_nfs { ( add n --) }{
			variable %mountd_handle  }
			_open_mountd 
			%mountd_handle !
			%mountd_handle @ IF
				_string_to_stack \ data n(--
				_#mountd_program _#mountd_version _#mountd_mount %mountd_handle @
				_rpc 
				?DUP IF   \ out_pep(--
					DUP ep_protodata + @ _rpcr_parameters 
					DUP @ not IF
						\ out_pep parameters(--
						4+
						%%fh_mount _#fh_size MOVE 
						kill_free_buffer
						%mountd_handle @ close
						EXIT
					ELSE
						@ _unix_code>string
						SWAP
						kill_free_buffer 
						%mountd_handle @ close
						$ABORT
					THEN
				ELSE
					TRUE ABORT" mountd won't talk"
				THEN
			ELSE
				TRUE ABORT" Can't open mountd"
			THEN
		;



		: _open_nfs ( --addr)
			%%mount_machine @ _get_nfs_port $" (udp_client)" zero $open
		;



		m: ( addr num --)
		
			
			\ just in case we abort. the close will still work as required.
			zero %%mount_machine$> !
			zero %%nfs_handle !

			this [parent] :construct
			[CHAR] / remove_leading
			[CHAR] / left_split 
			\ addr_machine count_machine addr_file count_file(--
			2SWAP DUP IF \ machine specified
				2DUP Sresolve_address %%mount_machine !
				DUP _#max_driver_string > ABORT" mount string too long"
				DUP #$count_length + get_free_buffer 
				DUP %%mount_machine$> !
				$make
			ELSE
				\ no remote machine speced
				TRUE ABORT" remote machine must be given"
			THEN
			\ addr_file count_file(--
			[CHAR] / remove_leading
			\ addr_file count_file (--
			DUP not IF
				\ try for root
				2DROP S" /"
			THEN
			\ get a fhandle from server
			_mount_nfs 
			_open_nfs %%nfs_handle !
		; overrides :construct


		m:
			\ ##### tell server about umount
			this [parent] :destruct
			%%mount_machine$> @ ?DUP IF kill_free_buffer THEN
			%%nfs_handle @ ?DUP IF close THEN
		; overrides :destruct

		m: ( indent --)
			CR DUP SPACES ." mount_class | " ." Object: " this .h  
			DROP send
		; overrides :print

	end_class mount_class

	: umount
		%mount_object @ IF
			%mount_object @ :destruct
			zero %mount_object !
		THEN
	;



	: Smount ( add n --)
		umount
		mount_class heap_object %mount_object !
	;

	: $mount
		COUNT Smount 
	;

	: mount ( [string] --)
		BL WORD $mount
	;


	: nfs_fhandle ( -- addr)
		%mount_object @ DUP not IF
			EXIT
		THEN
		:nfs_fhandle
	;

	zero
	DUP CONSTANT    _#fattr_type      4+	
	DUP CONSTANT	_#fattr_mode      4+
	DUP CONSTANT	_#fattr_nlink     4+
	DUP CONSTANT	_#fattr_uid       4+
	DUP CONSTANT	_#fattr_gid       4+
	DUP CONSTANT	_#fattr_size      4+
	DUP CONSTANT	_#fattr_blocksize 4+
	DUP CONSTANT    _#fattr_rdev      4+
	DUP CONSTANT    _#fattr_blocks    4+
	DUP CONSTANT    _#fattr_fsid      4+
	DUP CONSTANT    _#fattr_fileid    4+
	DUP CONSTANT    _#fattr_atime     8+
	DUP CONSTANT    _#fattr_mtime     8+
	DUP CONSTANT    _#fattr_ctime     8+
	    CONSTANT    _#fattr_length   

	\ the type codes
	zero CONSTANT _#nf_non
	1    CONSTANT _#nf_reg
	2    CONSTANT _#nf_dir
	3    CONSTANT _#nf_blk
	4    CONSTANT _#nf_chr
	5    CONSTANT _#nf_link

	zero
	DUP CONSTANT _#fopen_error_code 4+
	DUP CONSTANT _#fopen_fhandle    _#fh_size +
	DUP CONSTANT _#fopen_attr       _#fattr_length +
	    CONSTANT _#fopen_length
./version081/tcp/sort_key.png0100777000000000000000000000244007300314372014771 0ustar rootrootPNG  IHDR`KIDATx钣6P;egj\h*aԺ#E+zO@>y=O@>y=O@>y=O@>y=O@[/9^lҝw>٬v8=9$0K9vGU]KrG:џz #83g_|.-ƻY6K4{^\oʠFKz>?I=\}>`;/6~j\2͗&fx{O9?;Lg'^;ofcjsdm>ȱ߹Lr~qٽ}gަݼs^Aח|v-cǾ6)ҁ/8k%7`l:q4WVec;u}_]ugRMκ&Oygi\m 3alŝYWqS]ʒ|[{^.ż_O_fO^tf];({6VG?h5ѲǨ|֫­}0ўчf UyرhHtlMx naH% |}ߎ[@+p~|! j+n}V[9Vn5pw+{oo=O@>y aVOyk{\f`BG3ρAq)\`M~1r(hW]ޤr}kty~E#/޹֭jk+Kag8%Ņsw)/q2\kk+Ka(ޟv& F}֩)/qN5yn8am/X25]*+/o5hU[=bv8|mΫ}Z=e=}[e8jk+ MqFچmOyn2{' |{' sZwj'(' O@>y=O@>y=O@>y=O@>y=O@>y=O@>y=O@>y=O@>y=O@XIENDB`./version081/tcp/system_stack.png0100777000000000000000000001040107300314372015637 0ustar rootrootPNG  IHDR&PLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4D IDATx[FyO̭اb r0?+S[Bɽ-@[2 $ I~~?'ßOQ\%fc3z4 9v +3x s&mOs`W, rYu > $U)X=` MG$ m n.xңsՇ>[iI;?W%Mpցxf8dN.C0WIfk @\ФBf@g=Y/ ]ܶ!Ʈ~|>| =g># H5A@s A*8⓴ -r NĀq 0\)JO8H\$( $  ]a vSAQV޹#t0kxDg0:2Mu:"]f/f K![4tl}< H$e* x}(^S!r" u@D"$r!2ûݝHh"U+y!naȀE(2 D!&!Kܖ|a3,DuwP =,|qTe@Yo gk,t`gK%@J[! >;Aћq6$THf_L>2H^xd.a6H $(pq4A3&^@ YȀE(Dd(ȂJG#V[f<].X<AZ>l%2Z;C`Le,T!ĵ@6~X^3(ң|/W<\Lۀ(ɀ[|G!uܗQ ȀE(2 D! Qd@"BkQۀ|J;,p w ‷@8;'j۟Q4SWou+W)V!tq}R2i.Z9%3@S\z~dzMs.SuX{:"$x 8הugȀE(2 D! QԫK^@~hr+AR"YD?lPEDkJ"?DN2 r"}@D."#r#@fxWw۽XkyˁW;v3;[ȻkJUd@"BȀE(2 DD-i i9@~* &X j;!Vw($ LP9e]Ѝe -}f|L]3H>ez,j!F{b phT/2qF[ zx>\ ?2)fne H<ωRlUٜ@H80a m KڀX'& -O]A CcH]fY&sv ܳH92 d&+̀ i!z')y x j5@*q itiS]9xҔ rr>aay KBAo-C^O$Y\Y} Mv˜ Hw7qtuA喵ȀlHȿӈCx6!hP,uO#!x*6dĬpyJs3l8Wzw 3NPaVL/Hgu_N  qPjC1t-?a Ix}2 Y&2w]r/-H& u#1 !;ebdV 1 M@t5$e%*2 D! Qd@"B5Z3 B +'Y=O`GwHkt6 @EwO4{$kJUd@"BȀE(1eҞ]>Q ##qenkOG$tC?Ǚ5%sYE(2 D! Qd@"B겝|hr+AR"Y?lPEDkJ"?DN2 r"}@D."#r#@fxWw3]"E\EU&+y!naȀE(2 D!&!uVd@XE(2 DPeh5@\Hq R/ x|Cr>\4|s _ ZJC+g"4Na 2Yll'f24t9Bfx@c7rnaה VD! Qd@"S {)b@ 3 A.ڈ1 3 f!d{2 Āb@E wה ȀE(2 D! Qd@+z9 I,h3 eIENDB`./version081/tcp/tcp_demux.html0100777000000000000000000004670707300314372015320 0ustar rootroot COLDFORTH KERNEL

proto class

license
RFC793 TCP
RFC1122 More info

When system starts there has to be a tcp object contructed, but only one.

checksum will work as long as all the data is in host order, or all the data is in network order. We do the checksum in host order as the source and destination IP are in HOST order. This means received datagrams have to go throught tcp_net<>host before calling this routine 

 


	: tcp_checksum_calculation { variable %pep ( --checksum) }{
		variable %ipdata }
		%pep @ ep_ipdata + @ %ipdata !
		zero
		%pep @ [ ep_data ip_src + ]T LITERAL + 
		\ zero addr(--
		\ source and destination address
		DUP [ IP_ALEN 2* ]T LITERAL + SWAP DO
			I W@  +
		2 +LOOP
		\ protocol
		%pep @ [ ep_data ip_proto + ]T LITERAL + B@ +
		\ length
		%pep @ ep_ipcount + @ TUCK +
		\ If length is odd pad tcp out with zero. Buffers lengths
		\ are always divisible by cell so there is room to place 
		\ the byte
		\ length checksum(--
		SWAP DUP 01 AND IF
			\ checksum len(--
			zero 					
			OVER %ipdata @ + B!
		THEN
		\ checksum length(--
		%ipdata @ + %ipdata @ DO
			I W@ +
		2 +LOOP
		\ checksum(--
		DUP $10 RSHIFT SWAP $0FFFF AND +
		DUP $10 RSHIFT + 
		-1 XOR
		$0FFFF AND
	;		 
		
	
	\ The last tcp port supplied by the OS.
	ram_variable _%tcp_last_port
	\ so the tcp object can be found without doing a
	\ _tcp_find
	ram_variable _%tcp_object

The more lists the faster the demux, the more memory you use. Set as desired. 

 
	$80 CONSTANT _#tcp_head_num
	ram_variable _%tcp_table _#tcp_head_num CELLS ram_allot

_tcp_find and _tcp_release will be used in the protocol object. _tcp_add, _tcp_free? and _tcp_release will be used in the io_common object for open and close. 

 
	: _tcp_find ( local_port remote_ip remote_port --addr|zero)
		_%tcp_table _#tcp_head_num demux_socket_find 
	;

	#1sec #120 *  CONSTANT #tcp_time_to_live 

	\ make sure #tcp_time_to_live is same as #demux_time_to_live
	\ if they are not then extra code has to be added to change value
	\ for _tcp_add
	#tcp_time_to_live #demux_time_to_live ??=

	: _tcp_add ( object local_port remote_ip remote_ip_mask remote_port remote_port_mask -- $| addr 0 )
		_%tcp_table _#tcp_head_num  demux_socket_add
	;

	: _tcp_release ( addr --)
		demux_release
	;

	: _tcp_free? ( io_object port --)
		_%tcp_table _#tcp_head_num _demux_socket_free?
	;
	 
 
	\ you use this when you want the os to supply a source port, that
	\ is when you are a client.
	$8000 CONSTANT _#first_tcp_system_port
	$10000 CONSTANT _#last_tcp_system_port
	\ used to work out wrap around
	_#last_tcp_system_port _#first_tcp_system_port - 2 / CONSTANT _#tcp_range


	: _tcp_port { 
			variable %object 
			variable %remote_ip
			variable %remote_ip_mask
			variable %remote_port
			variable %remote_port_mask -- ( record ) }
		_lock_word
		_%tcp_last_port @
		_#first_tcp_system_port _#last_tcp_system_port WITHIN not IF
			_#first_tcp_system_port _%tcp_last_port !
		THEN
		_unlock_word
		_%tcp_last_port @
		\ if two tasks are trying at the same time
		\ one will get in first and the other will keep
		\ going.
		\ port(--
		BEGIN 
			%object @ OVER %remote_ip @ %remote_ip_mask @ 
			%remote_port @ %remote_port_mask @ _tcp_add
		WHILE
			1+ 
			DUP _#first_tcp_system_port _#last_tcp_system_port WITHIN not IF
				DROP _#first_tcp_system_port
			THEN
		REPEAT
		\ port record(--
		SWAP
		\ when we store the up to port we must make sure
		\ the task with the highest used port wins. It is a circular number
		_lock_word
		_%tcp_last_port @ 2DUP - ABS _#tcp_range > IF
			\ wraped around 
			MIN
		ELSE
			MAX
		THEN
		_%tcp_last_port !
		_unlock_word
		\ record(--
	;


	
	 
 

protocol class
		cell% instance_variable %%tcp_in_errors
		m: ( --)
			this [parent] :construct
			IPT_TCP   %%protocol_number !
			\ if we return $ we where not added to proto table
			\ and we should not try and remove ourselves.
			this IPT_TCP  proto_add not %%installed !
		; overrides :construct

Called if the byte order has to be swaped for network transmission. This is done in the interface just prior to transmission. On reception it is done after the protocol demux, otherwise we would have to demux twice. 

 
		: tcp_host<>net  ( ipdata --)
			\ I don't need it for coldfire and I havn't got time.
			\ You have to deal with the TCP field. Ip is handled by the
			\ ip layer. The application is responsible for the contents of the 
			\ TCP data stream.
		;

		m: ( pep --) 
			DROP
		\   ep_ipdata + @
		\   tcp_host<>net
		; overrides :proto_host<>net

The sequence includes the syn flag and the fin flag and they have to be added into the count. Keep test code length to min add complications inside the IF. As IF often fails and code is in the critical path.

Note that if the segment has no date the end_sequence is before the the start seqenece. 

 

		: _end_sequence { variable  %pep ( -- end_seq) }
			%pep @ ep_ipdata + @ #tcp_seq + @ 
			DUP %pep @  ep_start_seq + !
			%pep @ ep_protocount + @  
			%pep @ ep_ipdata + @ #tcp_flags + B@ 
			[ #tcpf_syn #tcpf_fin OR ]T LITERAL AND IF
				%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_syn AND IF
					1+
				THEN
				%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
					1+
				THEN
			THEN
			1- 
			+
			DUP %pep @ ep_end_seq + !
		;



		\ this uses the pep for guidence, but does't destroy it.	
		\ UDP uses an ICMP message to tell the remote machine a port is unreachable.
		\ TCP uses a reset message.
		\ This code is alos used with tcp.html to send reset packets.		
		
		: _send_tcp_reset { variable %pep -- }	
			%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_rst AND IF
				\ the packet was a reset. WE are not allowed to send
				\ a reset in responce. If we did packets to unopened
				\ ports would rattle around forever.
				EXIT
			THEN
			\ the new packet will have no data, it will be the same length or
			\ shorter than the current packet header ( options don't grow)
			%pep @ ep_protodata + @  %pep @ - get_free_buffer
			\ pep_new(--			
			%pep @ OVER setup_pep_from_pep
			\ well just go through and set the fields, just grin and look happy
			%pep @ ep_ipdata + @			
			\ pep_new ipdata_old(--
			OVER ep_ipdata + @
			\ pep_new ipdata_old ipdata_new(--
			OVER #tcp_dst + W@ OVER #tcp_src + W!
			OVER #tcp_src + W@ OVER #tcp_dst + W!
			OVER #tcp_flags + B@ #tcpf_ack AND IF
				\ rfc 793 page 65
				\ if the datagram contained an ack reply
				\ with a reset datagram containing the seqence number
				\ acked. Remember the sequence number acked is the next
				\ seqence expected, so the reset will be in the sequence
				\ number accepted by the end we are resetting.
				OVER #tcp_ack + @ OVER #tcp_seq + !
				#tcpf_rst OVER #tcp_flags + B!
				\ This is what the standard asks for I think it is wrong. I 
				\ think we should inc the sequence if the SYN bit is set
				\ and leave it a lone if not. If the SYN bit is set we are using
				\ the relevent data and should ack it's reception. But who am 
				\ I to question this.
				%pep @ ep_ipdata + @ #tcp_seq + @ 
				OVER #tcp_ack + !
			ELSE
				\ rfc 793 page 65
				\ We don't have a seqence to use as the received datagram
				\ didn't have it's ack bit set so the ack field is not
				\ valid, so use zero.
				zero OVER #tcp_seq + !
				[ #tcpf_rst #tcpf_ack OR ]T LITERAL OVER #tcp_flags + B!
				\ If there is no ack set, this datagram is the initial syn
				\ or rubbish, we have to ack the syn, as we use it to reply.
				\ What follows is the complete calculation as per standard. 
				\ Testing that the syn bit was set and incrementing the 
				\ supplied seqence by one would have also been acceptable and
				\ a better representation of the truth as we took the syn bit
				\ and nothing more.
				%pep @ ep_ipdata + @ #tcp_seq + @ 
				%pep @ _end_sequence  
				2DUP - 0> IF
					\ there was no data ( flag or otherwise), use sequence sent.
					DROP
				ELSE
					\ there was data, _end_seqence returns the sequence of the last 
					\ data item in datagram. The ack is for the next data item expected.
					NIP 1+
				THEN
				\ pep_new ipdata_old pep_new ack(--
				OVER #tcp_ack + !
			THEN
			\ pep_new ipdata_old ipdata_new(--
			\ ack the last sequence byte in packet. Doing it this way gets the
			\ reset inside e SYN packet window. A reset for a SYN packet will
			\ only be acecpted if the SYN is acked.
			[ #tcp_header_end 2 RSHIFT 4 LSHIFT ]T LITERAL OVER #tcp_offset + B!
			zero OVER #tcp_window + W!
			\ be neat
			zero OVER #tcp_urgptr + W!
			2DROP
			\ pep_new(--
			#tcp_header_end OVER add_to_ip
			\ so tcp checksum can be calculated by interface
			_%tcp_object @ OVER ep_proto_obj + ! 
			queue_ip
		;

We are in the time wait state. we have to ack a remote fin if it arrives. We make no assumtions about who or what from the remote fin we form a packet that will make the other end happy and send it.

We are doing this as a service for the other end. As soon as it gets an ack of the fin it can release it's resources. If you look at the tcp code you will see this is used to ack all fines. Doing that way allows the application to close down the tcp object easily. 

 
		: _ack_last_fin { variable %pep -- }	
			%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND not IF
				\ it's something else; lost in the internet for a while
				\ whatever it was it is now irrelevent.
				EXIT
			THEN
			\ the new packet will have no data, it will be the same length or
			\ shorter than the current packet header ( options don't grow)
			%pep @ ep_protodata + @  %pep @ - get_free_buffer
			\ pep_new(--			
			%pep @ OVER setup_pep_from_pep
			\ well just go through and set the fields, just grin and look happy
			%pep @ ep_ipdata + @			
			\ pep_new ipdata_old(--
			OVER ep_ipdata + @
			\ pep_new ipdata_old ipdata_new(--
			OVER #tcp_dst + W@ OVER #tcp_src + W!
			OVER #tcp_src + W@ OVER #tcp_dst + W!
			OVER #tcp_ack + @ OVER #tcp_seq + !
			#tcpf_ack OVER #tcp_flags + B!
			\ when setting the ack field remember the last packet may have contained
			\ data and a fin. We have to ack past the fin for the other end to be
			\ happy.
			%pep @ _end_sequence 1+ OVER #tcp_ack + !
			[ #tcp_header_end 2 RSHIFT 4 LSHIFT ]T LITERAL OVER #tcp_offset + B!
			zero OVER #tcp_window + W!
			\ be neat
			zero OVER #tcp_urgptr + W!
			2DROP
			\ pep_new(--
			#tcp_header_end OVER add_to_ip
			\ so tcp checksum can be calculated by interface
			_%tcp_object @ OVER ep_proto_obj + ! 
			queue_ip
		;

		\ used by the proto task to get rid of the packet.
		m: { variable %pep --  }
			\ set tcp pointer and count.
			\ These will be moved when urgent data is extracted,
			\ or if the packet contains data that is to be ignored 
			\ for some reason. We do not move the data. 
			%pep @ ep_ipdata + @
			%pep @ ep_ipcount + @
			\ ipdata ipcount(-- 
			OVER #tcp_offset + B@ #tcp_hlen>bytes_asr RSHIFT 
			\ ipdata ipcount header(--
			TUCK - DUP 0< IF   \ >
				\ the datagram is not long enough to contain the header
				\ ipdata header count(--
				DROP 2DROP
				1 %%tcp_in_errors +!
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ ipdata header count(--
			%pep @ ep_protocount + !
			\ ipdata header(--
			+ %pep @ ep_protodata + !

			%pep @ tcp_checksum_calculation 
			\ checksum calc includes checksum and result should be zero
			IF
				%pep @ kill_free_buffer
				1 %%tcp_in_errors +!
				EXIT
			THEN
			\ checksum is good
			
			\ -------------------------
			\ This is important
			\ -------------------------
			\ This bit of code is central to this implementation.
			\ 1) We do not use the local ip address in selecting the connection. So it is
			\ not important to know which local ip address is used to start the connection.
			\ It is important that we reply using the destination address of incoming
			\ datagrams. The datagram exchange when the connection is set up will select
			\ the source port.
			\ 2) The raw tcp packet is presented to the io object, that is the object
			\ created with open. It is the io objects job to look after the connection. 
			\ The TCP is implemented in the io object. A server will create an io object for all
			\ connections. All the standard forth io words will work against an open connection.
			\ 
			%pep @ ep_ipdata + @ #tcp_dst + W@
			%pep @ [ ep_data ip_src + ]T LITERAL + @ 
			%pep @ ep_ipdata + @ #tcp_src + W@ 
			\ sequence_length local_port remote_ip remote_port(--
			_tcp_find ?DUP IF
				\ table(--
				\ save the last access time

				xclock+ @ OVER 2DUP _#demux_time + !
				_#demux_try_time + !
				
				\ this is a method in io_common
				%pep @ OVER _#demux_object + @ ?DUP IF
					:consume_port
					_tcp_release
					EXIT
				ELSE
					DUP _ack_last_fin
					kill_free_buffer
					_tcp_release
					EXIT
				THEN
			THEN
			\ (--
			\ the port is unreachable
			\ Now if it was udp we would send a icmp port unreachable
			\ error message, but it is not the case with TCP.
			\ RFC793 page 65 is the place to look.
			\ This means we have to be able to create a valid TCP packet
			\ outside the device driver for the protocol, oh well.
			\ (--
			%pep @ _send_tcp_reset
			%pep @ kill_free_buffer
		; overrides :proto_demux

		
		m: { variable %pep -- }{
			variable %ipdata 
			variable %returned_hl }
			%pep @ ep_ipdata + @ %ipdata !
			%ipdata @ ic_data + _ip>ip_hlen
			\ header_length_returned_datagram(--
			%returned_hl !
			%pep @ ep_ipcount + @ ic_data - %returned_hl @ - #tcp_header_end < IF \ >
				\ (--
				\ didn't return tcp header
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ extracting source port etc.and have a go at queueing packet.
			\ ep_error is set before we get to this word.
			\ The contents of ep_error will be seen by the
			\ io_common object and result in a error output.
			\ header_length_returned_datagram(--
			\ remember the datagram is as we sent it
			\ the destination is the remote.
			%ipdata @ ic_data + %returned_hl @ + #tcp_src + W@
			%ipdata @ ic_data + ip_dst + @
			%ipdata @ ic_data + %returned_hl @ + #tcp_dst + W@
			_tcp_find ?DUP IF
				\ table(--
				\ this is a method in io_common
				%pep @ OVER _#demux_object + @ ?DUP IF
					:consume_port
					_tcp_release
					EXIT
				ELSE
					\ no one is interested. Just like humans
					\ complain and no-one is interested.
					kill_free_buffer
					_tcp_release
					EXIT
				THEN
				\ if we are in the timewait state we are not interetesed in errors
				\ noone is going to use them and we do not repond to them
			THEN
			\ get here and there is nowhere for error to go
			\ give up
			%pep @ kill_free_buffer
		; overrides :proto_error





		\ TCP requires checksuming
		\ after the source ip address is known.
		\ The source ip address should be determined by 
		\ the interface over which the packet is sent.
		\ Instead of guessing the source ip address we provide
		\ the protocol object and the interface calls :proto_checksun
		\ just before doing the ip checksum, and before converting
		\ the ip header to network order.
		m: { ( pep --) }{
			variable %ipdata }
			DUP ep_ipdata + @ %ipdata !
			zero %ipdata @ #tcp_checksum + W!
			\ pep(--
			tcp_checksum_calculation
			\ checksum(--
			%ipdata @ #tcp_checksum + W!
		; overrides :proto_checksum	
		
		\ tell the world about ourselves
		m: ( offset --)
			CR DUP SPACES ." tcp_protocol  | " ." Object: " this .h 
			              ." protocol_number: " %%protocol_number @ .h
			              ." installed: " %%installed @ IF
                              ." Yes"
			              ELSE
			                  ." No"
			              THEN
			DROP
			send
		; overrides :print

end_class tcp_protocol

To make life simple for this code, this code removes all entries otherwise we are tracing down a list that can lose entries, not a good thing. It doesn't matter if entries get added while this code is being executed. 

 
	CREATE $timeout ," Connection has timed out"
	: _tcp_timeout ( --)
		_%tcp_table _#tcp_head_num CELLS + _%tcp_table DO
			I 
			BEGIN
				DUP @
			WHILE
				DUP @ _#demux_live_time + @ -1 <> IF
					\ if we have exceeded max quite send an out of bound packet 
					\ if the computer is still there it will send an ack if not
					\ timeout will continue
					DUP @ _#demux_live_time + @
					OVER @ _#demux_time + @ +
					xclock- @ + 0< IF \ >
						\ entry has timed out
						\ list(--
						DUP @ _#demux_object +
						\ we can't be sure that task is trying to use port
						\ we can be really unlucky it is trying to close it when we time it out
						\ so we have to lock the processor when queueing a $timeout message 
						_lock_word
						@ not IF
							_unlock_word
							\ the device object has gone we only have to delete this entry
							DUP @ _tcp_release
							\ we don't have to fetch the next as the 
							\ next should be gone and it it hasn't 
							\ it's because there has been to many finds and
							\ not enough releases. A few more times around will fix that.
						ELSE
							\ it is the responsibilty of the object to set the
							\ #demux_object pointer to zero.
							\ Update object to current time so object has time
							\ to get it's act together.
							xclock+ @ OVER @ 2DUP _#demux_time + !
							_#demux_try_time + !
							$timeout ep_data get_free_buffer
							\ list $ pep(--
							\ abort_connection will enable interrupts.
							jump @ _#demux_object + @ :abort_connection
							@
						THEN
					ELSE
						\ we have three goes at getting a responce.
						DUP @ _#demux_live_time + @ 4 / 1+
						OVER @ _#demux_try_time + @ +
						xclock- @ + 0< IF \ >
							xclock+ @ OVER @ _#demux_try_time + !
							DUP @ _#demux_object + @ :hay_you_there
						THEN					 
						\ move to next entry in list
						@ 
					THEN
				ELSE
					@
				THEN
				\ list(--	 
			REPEAT
			DROP
			xpause
		cell +LOOP
	;


	: .tcp_demux ( --)
		CR
		." lc port  "
		." users    "
		." object   "
		." rm port  "
		." rm p mk  "
		." rm ip    "
		." rm ip mk "
		." live tm  "
		_%tcp_table _#tcp_head_num CELLS + _%tcp_table DO
			I 
			BEGIN
				@ DUP
			WHILE
				CR
				\ addr(--
				DUP _#demux_local_port + @ .h 
				DUP _#demux_users + @ .h
				DUP _#demux_object + @ .h
				DUP _#demux_remote_port + @ .h
				DUP _#demux_remote_port_mask + @ .h
				DUP _#demux_remote_ip + @ .h
				DUP _#demux_remote_ip_mask + @ .h
				DUP _#demux_live_time + @ .h
			REPEAT
			DROP
		cell +LOOP
	;
./version081/tcp/udp.html0100777000000000000000000003377507300314372014121 0ustar rootroot COLDFORTH KERNEL

the I/O classes for UDP

license
RFC768 UDP
RFC791 IP
RFC1122 Host requirments

A user opens a udp_client or udp_server to use the udp protocol.

Ininitially we tried to write this so the application program only sees the udp data; but it got too massy and the rules of use too compliced. So we have gone for a pep address with support routines.

The result is resonable need, the file ip_setup.html contains the raw ip setup words. These are used by the udp methods tp produce udp datagrams.

You can use :read and :read_line to extract data from the udp. The open has the form driver/destination_machine/destination_port 

  
	: shout
		S" udp_client/123:444:123:555/07" zero Sopen
		\ object(--
		S" A string to echo" jump :write
		\ send_udp
		DUP :flush_file
		\ 
		$buffer
			buffer OVER :read TYPE
		kill_buffer
		close
	;
 
 

	: Sresolve_address ( addr count -- ip)
		Snumber 
	;

	: $resolve_address ( $ --ip)
		COUNT Sresolve_address 
	;


io_protocol_common class	

		cell% instance_variable %%remote_port
		cell% instance_variable %%local_port
		cell% instance_variable %%demux_structure
				
		\ errors/stats
		cell% instance_variable %%bad_udp_datagram
		cell% instance_variable %%read_errors
		cell% instance_variable %%option_error

		m: ( parent--)
			this [parent] :construct
			zero %%bad_udp_datagram !
			zero %%read_errors !
			zero %%option_error !
			zero %%remote_port !
			zero %%local_port !
			zero %%demux_structure !
		; overrides :construct

		m: ( --)
			\ Remove ourselves from the udp_demux table.
			zero %%demux_structure @ _#demux_bucket_object + ! 
			%%demux_structure @
			BEGIN 
				_lock_word 
				DUP _#demux_bucket_users + @ 1 <>
			WHILE
				_unlock_word
				xpause
			REPEAT 
			\ this will unlock
			DUP unlink_double
			kill_free_buffer			
			this [parent] :destruct
		; overrides :destruct

		m:  ( machine port addr num mode -- instance )
			%%mode !
			2DROP
			%%remote_port !
			%%remote_machine !
			\ ask the os for a demux entry, this also provides a local port
			\ as soon as we do this we can start receiving 
			\ datagrams destined to the allocated port.
			\ As no one knows about us it is not likely, but it
			\ is possible.
			\ This adds to the udp demux table.
			\ We are a client, we care about detination machine and port
			this 
			%%remote_machine @ -1 
			%%remote_port @ -1
			_udp_port %%demux_structure !
			%%demux_structure @ _#demux_local_port + @ %%local_port !
			this
		; overrides :Sopen

		: setup_udp { ( source_port destination_port) variable %pep -- }

			_%udp_object @ 	%pep @ ep_proto_obj + !
			
			\ points to data portion of udp datgrame, and gives the data count.
			%pep @ ep_ipdata + @ udp_data + %pep @ ep_protodata + !
			zero %pep @ ep_protocount + !

			IPT_UDP  
			%pep @ [ ep_data ip_proto + ]T LITERAL + B!
		
			%pep @ ep_ipdata + @ udp_data ERASE

			%pep @ ep_ipdata + @ udp_dst + W!
			%pep @ ep_ipdata + @ udp_src + W!

			udp_data %pep @ ep_ipdata + @ udp_len + W!
	        \ add udp header to datgram length. 
			udp_data %pep @ add_to_ip
		;

		m: { variable %pep -- }
			%%local_machine @
			%%remote_machine @ 
			zero %pep @ setup_ip
			\ priority can be set as a object variable
			%%priority @  5 RSHIFT 
			%pep @ [ ep_data ip_tos + ]T LITERAL + B! 
			\ ------------------------------------------
			\ this word sets up a header with no options
			\ if you want options do it yourself.
			\ ------------------------------------------
			\ setup the udp header
			%%local_port @
			%%remote_port @
			%pep @
			setup_udp

		; overrides :setup_protocol


		: add_to_udp ( n pep)
			2DUP ep_protocount + +!
			2DUP add_to_ip
			ep_ipdata + @ udp_len + DUP W@
			ROT + SWAP W!
		;

An application should call :setup_protocol or :setup_protocol_from_pep

to initialise the pep header. It should then alter header if desired. Application should than call :write_protocol

Note this word will abort if the options contained in %pep_in are rubbish. 

 
		m: { variable %pep_in variable %pep_out --  }{
			variable %ipdata_in }
	
			%pep_in @ ep_ipdata + @ %ipdata_in !

			%pep_in @ %pep_out @ setup_pep_from_pep
			\ destination of incoming is source of outgoing
			%ipdata_in @ udp_dst + W@
			%ipdata_in @ udp_src + W@
			%pep_out @
			setup_udp
		; overrides :setup_protocol_from_pep 



		CREATE $udp_struct_bad ," udp packet structure bad"
		: _pep>udp_data ( pep -- pep addr n 0 | $)
			DUP ep_ipdata + @
			\ pep addr(--
			DUP udp_len + W@ 
			\ pep addr len(--
			jump ep_ipcount + @ OVER < IF
				\ pep addr len(--
				\ udp count too large
				ROT kill_free_buffer
				2DROP
				\ (--
				$udp_struct_bad
				EXIT
			THEN
			udp_data - 
			SWAP 
			udp_data + 
			SWAP
			zero
		;

		\ The big qestion; should We close on an abort or leave it
		\ to the user. The rule is if you take one of these words you can 
		\ convert it into a ior type result with a simple catch. That means
		\ you don't close
		m:  { ( --pep addr n ) }
				%%pep_queue %%timeout @ xawait_timed IF
					\ timout
					0 0 0
					EXIT
				THEN
				%%pep_queue dequeue
				\ pep(--
				DUP ep_error + @ not IF
					_pep>udp_data ?DUP IF
						1 %%bad_udp_datagram +!
						$ABORT
					THEN
					\ pep addr n(--
					EXIT
				THEN
				1 %%read_errors +!
				DUP ep_error + @
				SWAP kill_free_buffer
				$ABORT
		; overrides :read_protocol

		\ the read operation treats each datagram
		\ as a record.
		m:  ( addr len -- len)
			%%active_pep @ not IF
				this :read_protocol
				%%active_count !
				%%active_pointer !
				%%active_pep !
			THEN
			\ addr len(--
			_read_from_active_pep
			\ len(--
		; overrides :read

		\ write the data pointed to by addr and n to the pep and queue
		m: { ( addr n) variable %pep ( --) }
			DUP IF 
				TUCK
				\ n addr n (--
				%pep @ ep_ipdata + @ udp_data + SWAP MOVE
				\ n(--
				%pep @ add_to_udp
			ELSE
				\ empty datagram head is ok as is
				2DROP
			THEN 
			\ wait for room on the queue.
			%pep @ queue_ip_wait
		; overrides :write_protocol

		\ returns true if data
		m: ( --flag)
			%%active_pep  @ 0= 
			%%pep_queue queue_empty? AND not
		; overrides :key?


		m: ( indent --)
			CR DUP SPACES ." udp_client | " ." Object: " this .h 
			CR DUP SPACES ." remote machine: " %%remote_machine @ .h 
			              ." remote port: " %%remote_port @ .h
			CR DUP SPACES ." source machine     : " %%local_machine @ .h
			              ." local port     : " %%local_port @ .h
			CR DUP SPACES ." priority           : " %%priority @ .h
			              ." input_pep_queue : " %%pep_queue .h
			CR DUP SPACES ." datagram receives  : " %%datagrams_received @ .h
			              ." discards        : " %%datagram_discards @ .h
			\ indent(--
			CR DUP SPACES ." type buffer        : " %%type_buffer> @ .h
			              ." type count      : " %%type_buffer_count @ .h
			DROP
			send
		; overrides :print

target_also
&drivers
target_definitions

end_class (udp_client)
.S .( after (udp_client)
target_previous_definitions
target_previous


\ only overrides :Sopen
(udp_client) class


		\ string can be /destination_machine/destination_port 
		\               //destination_port
		\               or nothing
		m: { ( addr n mode -- instance ) }{
			variable %mode
			variable %remote_port
			variable %remote_machine
			}
			STATE @ .
			%mode !
			\ /machine/port
			[CHAR] / remove_leading
			[CHAR] / left_split 
			\ addr_machine count_machine addr_port count_port(--
			2SWAP DUP IF \ machine specified
				Sresolve_address %remote_machine !
			ELSE
				2DROP  zero %remote_machine !
			THEN
			\ addr_port count_port(--
			[CHAR] / remove_leading
			DUP IF \ port speced
				Snumber %remote_port !
			ELSE
				2DROP zero %remote_port !
			THEN
			%remote_machine @ %remote_port @ zero zero %mode @ this [parent] :Sopen
			STATE @ .
		; overrides :Sopen

		m: ( indent --)
			CR DUP SPACES ." udp_client | " ." Object: " this .h  
			DROP send
		; overrides :print

target_also
&drivers
target_definitions

end_class udp_client

target_previous_definitions
target_previous


(udp_client) class


		m: ( parent--)
			this [parent] :construct
		; overrides :construct

		m: ( --)
			this [parent] :destruct
		; overrides :destruct

		\ client first, string should be zero
		\ mode is stored
		\ :Sopen
		\ string has to be /source_port 
		m: ( local_port addr num mode -- instance )
			%%mode !
			2DROP
			%%local_port !
			this %%local_port @ 0 0 0 0 _udp_add $ABORT	
			%%demux_structure !
			this
		; overrides :Sopen



		\ The big qestion; should We close on an abort or leave it
		\ to the user. The rule is if you take one of these words you can 
		\ convert it into a ior type result with a simple catch. That means
		\ you don't close
		m:  { ( --pep addr n ) }
			BEGIN
				%%pep_queue xawait
				%%pep_queue dequeue
				\ pep(--
				DUP ep_error + @ not IF
					_pep>udp_data not IF
						\ pep addr n(--
						EXIT
					THEN
					1 %%bad_udp_datagram +!
				ELSE
					1 %%read_errors +!
					kill_free_buffer
				THEN
			AGAIN
		; overrides :read_protocol

		m: ( indent --)
			CR DUP SPACES ." udp_server | " ." Object: " this .h 
			CR DUP SPACES ." source machine     : " %%local_machine @ .h
			              ." source port     : " %%local_port @ .h
			CR DUP SPACES ." priority           : " %%priority @ .h
			              ." input_pep_queue : " %%pep_queue .h
			CR DUP SPACES ." datagram receives  : " %%datagrams_received @ .h
			              ." discards        : " %%datagram_discards @ .h
			\ indent(--
			CR DUP SPACES ." type buffer        : " %%type_buffer> @ .h
			              ." type count      : " %%type_buffer_count @ .h
			CR DUP SPACES ." read errors        : " %%read_errors @ .h
			DROP
			send
		; overrides :print

target_also
&drivers
target_definitions

end_class (udp_server)
.S .( after udp_server)
target_previous_definitions
target_previous


(udp_server) class

		\ client first, string should be zero
		\ mode is stored
		\ :Sopen
		\ string has to be /source_port 
		m: { ( addr n mode -- instance ) }{
			variable %mode
			variable %local_port
			}
			%mode !
			\ /machine/port
			[CHAR] / remove_leading
			[CHAR] / left_split 
			\ addr_machine count_machine addr_port count_port(--
			2SWAP DUP not ABORT" Local port not specified"
				
			Snumber %local_port !
			2DROP
			%local_port @ zero zero %mode @ this [parent] :Sopen
		; overrides :Sopen

		m: ( indent --)
			CR DUP SPACES ." udp_server | " ." Object: " this .h  
			DROP send
		; overrides :print

target_also
&drivers
target_definitions

end_class udp_server

target_previous_definitions
target_previous
.S .( after udp_server)
RFC862
 
	: _udp_echo_server { -- }{
		variable %handle 
		variable %pep }
		S" udp_server/07" zero Sopen %handle !
		\ (--
		BEGIN
			%handle @ :read_protocol 
			\ pep addr n(--
			ROT %pep !
			\ addr n (--
			\ The options length will be the same or shorter 
			\ than the incoming options.
			%pep @  DUP %handle @ :setup_protocol_from_pep 
			\ addr n (--
			%pep @ 
			\ addr n pep(--
			%handle @ :write_protocol 
		AGAIN
	;

	 
 
	: _receive_ping { ( object --) }{
				variable %buffer }
		%buffer 4 ROT :read
		\ count(--
		IF
			%buffer @ xclock+ @ _#trr1_value * _wreg_TCN1 W@ + +
			\ delay(--
			\ rescale to msec
			#10 _#trr1_value */ 
			\ delay(--
			5 .R ."  ms" send			
		THEN
	;


	\ flag is true if message received
	: _ping_message { ( object -- flag ) }{
			variable %buffer }
		\ object(--
		\ we are going for a simple ping. Send a message wait for responce, print 
		\ time. 1/10th msec
		xclock- @ 1+ \ add the full 10 msec
		_#trr1_value * 
		_wreg_TCN1 W@ -  \ subtract actual value
		%buffer !
		%buffer 4 jump :write
		DUP :flush_file
		xclock+ @ #1sec + >R
		BEGIN
			xpause
			\ object(--
			^C
			DUP :key?
			IF
				r>drop
				\ object(--
				_receive_ping
				\ (--
				TRUE 
				EXIT
			THEN
			R@ xclock- @ + 
			0> not
		UNTIL 
		r>drop
		DROP
		FALSE
	;

	: udp_ping { ( --) }{
		variable %sent_messages
		variable %received_messages 
		#8 CONSTANT #colume_size
		}
		0 %sent_messages !
		0 %received_messages !
		$" udp_client/" BL WORD #$buffer get_buffer buffer #$buffer $+
		buffer $" /#07" buffer #$buffer $+  
		buffer zero $open kill_buffer

		CR
		BEGIN
			\ object(--
			DUP :key? IF
				CR
				\ object(--
				DUP ['] _receive_ping CATCH ?DUP IF
					CR 
					." sent messages: " %sent_messages @ .
					." recieved messages: " %received_messages @ . 
					NIP SWAP close
					$ABORT
				THEN
				1 %received_messages +!
			ELSE
				1 %sent_messages +!
				\ object(--
				DUP ['] _ping_message CATCH ?DUP IF
					CR 
					." sent messages: " %sent_messages @ .
					." recieved messages: " %received_messages @ . 
					NIP SWAP close
					$ABORT
				THEN
				IF 
					1 %received_messages +!
				THEN
			THEN
			character# #colume_size + character_max @ < not IF CR THEN 
			\ don't want internet to get upset with ping rate.
			#1sec xtest xwait
		AGAIN
	;
./version081/tcp/tcp_diag2.png0100777000000000000000000001317207300314372014772 0ustar rootrootPNG  IHDR:r0PLTE{IDATxIәپ)1z3LbNҩyQ?EM'BZE}ӹ_$]:W@Hzɚ tJ*`: /p4rp(ptrͥGhtԷ2Z{U'vÁ# o0ґ`+{5}:#hhkwNt>Yv'/:>>lJFcܨvǵ:Η,F tr,Y@'gᮏ;r,Y@'gN:9 tr,Y]gZӪ:O:9 tru*q~]4h:|Ont}Ņ̺I^BGCB;l̺¯u:?D~C:C"95C>v`:fF(lק{ E3Ցl4S(# 3:@D tD t"5J'Ό*P98smVP[ : tn7v@獝(:㾯Hlc/:{w&W3beXng'Fzspy'XV7 +o'KR[HNbg yRLۺEAgnmmmǶO Ã+ )Ac|Qg<QsĬIRSO\ꙇ2FڇxYYIGzNJ-/0?>9R ǠUbeud4 l8%=.to!GSZF F1. y]AI`ڋibGSCbG߻lcG+ybG+ dɴal㋜ѝ;3ӑ\75o*fߚiu=m4骐X(kRvS8j17mBMcJ~qgB lGM7N[.GZ褤pz:#tJЉ褤t*K_AgT)tU] S3j"ЙСtxmBRR :D5Fc:))"N+I6H褤:)| gx;z,0:KniDo̯Ź݆+s-M@t@t@,tzPthй ҩ&gd.sy.+oq^_TPʖURU|c(+ _װ| *bI-r{L/:E<3عD6.2{Hq 'k&!vNȺEn]_$Hd0D㾸]uT4t.K*w`}-_^Jͦ/ΞN QLeU펀jEc'БӅҡ@Z: #[/V-_~\k+硣!fkzMB&3;C7@:; @bNS@&; WP-rs F0JGCH(,JiwWPzU+F#N}^\۝צݩ4vQjgtO 6sN9wٵYLf t@t@t1w}|"W\&[1 SxNjNKgQvA'f[ЉrwJs@$(-D;%9L to]oީV5rnCۂw;z tpwbF,s7NlEӈoUv :i?\H_tvp:|S r-S!nRnI[fs~p,ЍdM~-.*Gs8ܧ kAgoiV~(ǎ|9D-Pq#j+jC+2W^ 4~6:t,\Y@'gNJT~14:&iyZ4,$fKЉNK tf:9 tr,Yfd&}^n{T{1,@gVFskWQKnhR0FxcH<$iЏNtfE'oxpehN6GYNOr7KCi"#l-/VM(-x =Yͫ%>ڵe'duX~ՋlܬV6$9teO&:M/v>T1>v$pd]/vD.BkwNljFʳ4ά| Zimnȷ]k*)00cl0 )|5YESYӱii$&INK tf:9 trM]j~86@t2,Y@'gN:9 tr,Y@'gNΊyOdNu'0,96TM'7"?; : tDx:ʉQ9Vjn[Gu])jHxʥtvPA:Uŷө.jK7)e\Unj6GL;j\0etxm:Ā H$4QU;txj_Ks$NH>ߥJ!9 A)=:l'y_LGž΂Q:zH"D5NN%/jQLGC&>;'OB4!ghZ,qVj6ٴ)#;Z+{TO1ft}j4݌d@t͇N.UУ Lz^'9L*,KQw}"L ֤3ZXX$un:r勯֠zttj:[ F kNJE6V0ZXX$:@g/Yo? tZ*%7s@'gN%w.T>Ͽ6t䡏J~A0EwxӣS2Fknc@kx@gK-5:37\m2 :i1%u4sَ:!Бk t@'k:g,YNliF&'K/ޭc]":9 tr,Yй3Lt>D}:{1+pE>A)F (hތ%d&Ntq#;n<=n{z rQ$Cqxv0U]O@^޵>%tښ-KN : t66M8*;B0NN5oĎW:low`0IB>[;:M/CC; tvH"VVgI:9ަ3ѯlZJg厙9tV:C:3Й*[ '1:@G:{ t@gK tΖ-Ul3j:E i:t@gΤ@goQ+NAIJ~(L[\Ȭ%N=k6ǂHfdׂNOU~@D"y~55C>v÷;_Fw)鄚P]j6iuL@^AQ^+8NFg#=|6zjN:7:9>71C$7/=3cv&ybWV̺葡tzDĎi$wjZ?|/``>Ķ6WvY{iw|G_ݱNC&Ll64F`@$--MD=kmtNpW'6׭ nr`}zP0+>.+"gҙ4SYA'gktr]iK:=JSAgQ֠:Ag5x}D2kĎg :֠:?N왷f S@'.[q4;OHqx6:I֏r鏢щUƫ::::)GH~j :C.5t$'#bt 9^S]~p1E'ºg_Q]d)$҉-Z){ߥ@KXNQyVVtN$Y@'gNڇ@'gN:9 tr؏yx IENDB`./version081/tcp/tcp_h.html0100777000000000000000000000537107300314372014415 0ustar rootroot COLDFORTH KERNEL license

TCP header file

RFC793 TCP
RFC1122 More info

I think I grok it, Time to start.

TCP state

The standard describes a loverly state diagram. Thats how we are going to go it. The state valuse are table offsets. 

 
zero 
DUP CONSTANT #tcps_closed         CELL+  \ 0
DUP CONSTANT #tcps_abort          CELL+  \ 4 protocol has aborted link
										 \ task using link will close
										 \ if we go through this there is no timewait
DUP CONSTANT #tcps_listen         CELL+  \ 8
DUP CONSTANT #tcps_synsend        CELL+  \ 0C
DUP CONSTANT #tcps_synrcvd        CELL+  \ 10
DUP CONSTANT #tcps_established    CELL+  \ 14
DUP CONSTANT #tcps_finwait1       CELL+  \ 18
DUP CONSTANT #tcps_finwait2       CELL+  \ 1C
DUP CONSTANT #tcps_closewait      CELL+  \ 20
DUP CONSTANT #tcps_lastack        CELL+  \ 24
DUP CONSTANT #tcps_closing        CELL+  \ 28 task will close link, the demux table will
                                         \  keep an entry to deal with timewait.
DUP CONSTANT #tcps_timewait       CELL+  \  task will close the link but will leave
                                         \  the demux entry.

    CONSTANT #tcps_error

Structure of a TCP datagram; a TCP packet has options just like an ip packet, so the offset byte has to be consulted. 

 
	zero 
	DUP CONSTANT #tcp_src      2+
	DUP CONSTANT #tcp_dst      2+
	DUP CONSTANT #tcp_seq      4+
	DUP CONSTANT #tcp_ack      4+
	DUP CONSTANT #tcp_offset   1+
    DUP CONSTANT #tcp_flags    1+
	DUP CONSTANT #tcp_window   2+
	DUP CONSTANT #tcp_checksum 2+
	DUP CONSTANT #tcp_urgptr   2+
	    CONSTANT #tcp_header_end

The flag byte is arranged as follows. 

 
	$01 CONSTANT #tcpf_fin     \ finish flag
	$02 CONSTANT #tcpf_syn     \ sync flag
	$04 CONSTANT #tcpf_rst     \ reset flag
	$08 CONSTANT #tcpf_psh     \ push the data
	$10 CONSTANT #tcpf_ack     \ ack field valid
	$20 CONSTANT #tcpf_urg     \ urgent pointer valid

Shift value to convert header length stored in datgram to header length in bytes.
Value is stored in top 4 bits and gives number of 32 bit words. 

 
	4 2 - CONSTANT #tcp_hlen>bytes_asr
./version081/tcp/tcp_rcv_win.png0100777000000000000000000000144307300314372015451 0ustar rootrootPNG  IHDRO0PLTE{IDATxk -e8 !e|jLt#bAD[+ }ooݲ?Ԑx:ҝGÿ >}Em &O×yK|4>´z:@k"Ħ|t hkzpT5IGԄT~Rʁt Fu #5t' ŧ'xde:c'@\n\x{|! ȬCU>=S } o $6#$6׀o^f=Ͽ|=ؤto#kM@FbRbWף{i19.}/-}/4v,~B1ǖN%>M\s_Zjѹsۉ?U ~ IENDB`./version081/tcp/tcp_snd_win.png0100777000000000000000000000376707300314372015456 0ustar rootrootPNG  IHDRTs !0PLTE{IDATxm* k5Ew2^|ҍtҒw{>X@ 9>Qr+P Tn*[-EEV.dU*P@fCEdQwå&!T?O:ui< ]{yyWtr 7QSnQ>lN O9I6&Xny<9ϜsU=sm}V-0ZO^A¤I(癥Vؘe*۪.pb:\׮yES֨FUA *[A,L#ЭVP3t.9ԂJi@PfrŲ 9|Yڥ#udmV"Ÿ+Tc_ڪz}ajllUw6D?ՄTW6F6woU e'_bC 5'P :JG+F\Eubu*jj=µU%3)l|Jmg R!u2=Tֹ[ ~tү * Wu!הfUbJ "V 6pu :O;n2W=6Eu?jO6׃qnA G:}6*4P@BߏFkUP Tn*[ʭ@Vr+P Tn*[ʭ@Vr+P Tn*[ʭ@Vr+P Tn*[ʭiP@@}cLċ)qg rj7{Nh뉗jo*PXzQvmU$@gHc,fr I;^9P΃iwrxtJ%;Mjj+YֵOc?Ɠ͞ʭ?Q*o5pYb (˔Rꡊ xp;26yQe&E[ʭiP݃M.*9p]8>r.ۀ'._Jrꢊ xp{Qh7po8 Tn*A5/;ep.FމjAP.!t.rXUU._i_Ӹp7\ *[Ӡ:~~T.pͱe:-H \>$1×_p9*ࢣ_q3E zQ+P Tn*[ʭ@tȂy]\Ԯ6Z^Jua,uPqDYfϢ^/.C0vQ hOƀ_}c"=HO2tOݔӕ#pARXY,'PAeYCgaDG^\A|~rZD*ʥr۷yb=*}]&C]9@oOR@K,Ae߭#7Ɔ(|7.*yPH ѫ03I 楛T?쨨UYbP-jva bg׈Gh+ Q+ %gr~hYTn.ʖx&?*nQ_nmљcFdEU TnxE<1vEvoW뿇 D2H4iCHؤѮJ;J^mowpl k,.1,{6*`Ia Jl5Cd=)55JeE6K`DecL;[FXXY4fDY9dqdi)XȂu`AU* J *ݼT[{!5bXdޟj Zӯ mJ6NƗT'.[xqZ2XLiFԷs,w[xYFoѮ4 Tn*[ʭ@Vr+P Tn*={ bIENDB`./version081/tcp/tcptmp.html0100777000000000000000000045014507300314372014632 0ustar rootroot COLDFORTH KERNEL

the I/O classes for TCP

license
RFC793 TCP
RFC879 TCP
RFC1122 More info
RFC1323 New options
RFC1185 Time wait
TCP/T
RFC1379 More info
RFC1644 More info
RFC1700 Assigned ports

A user opens a tcp_client or tcp_server to use the tcp protocol. 

 


io_protocol_common class
Tcp timer values in ticks ( 10 msec increments) 
 
        #50          CONSTANT #rexmt_default_value
        #5           CONSTANT #tcp_ack_delay
        #1sec #120 * CONSTANT #time_wait_delay

These we set to whatever we like. This system does not allocate buffers of this size. These determine what we advertize, and how much data we will queue. The data is left in peps until it is presented to the task consuming it. The I/O routines or the task sending the data converts it to peps before we see it. When we send data we copy a pep and send it on it's way. We do not repackage data if other end partly receives a pep. If your communicating with systems that have very small data buffers this will effect performance. This TCP stack is written for embedded systems. Technology being what it is today has made TCP a viable option. In my view it is more important to get good performance in systems with large buffer space. Things have been done to minimise computation and data movement. 

 
        8000 CONSTANT #rcv_data_buffer
        8000 CONSTANT #snd_data_buffer
If we don't get a reponce after this many tries, abort the connection 
 
        #8   CONSTANT #abort_retries

Tf the timeout gets above 20 seconds it really is pretty much a waste of time. If this TCP stack ends up on a Mars probe yes it is too short. Chances of that happening, zero. 

 
        #100 #20 * CONSTANT #max_timeout

Rfc879 page 5, and see RFC 1122 section 4.2.2.6. This is the internets default tcp data size. To get the default tcp datagram size you have to add the tcp header size and ip header size. 

 
        #536 CONSTANT #default_mss

The inital sequence number is to be based on a clock that increments every 4 microsecs. There are 10000 microsecs to a tick. so there are 

 
        #10000 4 /    CONSTANT _#tcp_ticks>ticks

The number of packets that can be placed in each of the tranmit queues. 

     
        $30          CONSTANT _#transmit_queue_size

The lists are implemented as single list queues. 

 
		1            CONSTANT _#transmit_queue_priorities

The server can create clients the clients thus created are link into here. 

 
			double% instance_variable %%server_link
link into transmit task

We need to talk about this a bit. When we receive a datagram from the remote machine we do not generate a direct reply. This is not an ack nack protocol. When we receive we update the data areas to reflect what has been recieved, and schedule a transmit. If something else has scheduled a transmit earlier then so be it. The tranmit routine will create a packet based on the current receive state.

This links together objects that the transmit task must look at. Exch open tcp link is represented by an object. If an object ins't linked into this list there is no transmit scheduled. The list is maintained in timeout order. The transmit task only deal with the list until it finds objects that havn't timed out. 

 
			double% instance_variable %%transmit_link

When this object wants the transmits to occure. 

 
		cell%   instance_variable %%transmit_time

Set to true if object is in transmit_list 

 
		cell%   instance_variable %%transmit_in_list

%%local_machine and %%remote_machine are defined in io_protocol_common. 

 
		cell% instance_variable %%remote_port
		cell% instance_variable %%local_port

The address of the table created when this io object was added to the demux routine. We don't own it, but we need it's address for the close. 

  
		cell% instance_variable %%demux_structure

If you get a count here ther is an error in this code. 

 
		cell% instance_variable %%tcp_state_error
		cell% instance_variable %%read_error
Round trip time

How long before we retransmit in ticks 

 
		cell% instance_variable %%tcp_rexmt
		cell% instance_variable %%tcp_rtt
		cell% instance_variable %%tcp_rtt_smooth
		cell% instance_variable %%tcp_rtt_dev

The tcb state; see rfc 793. 

 
		cell% instance_variable %%tcp_state

Packets unsent don't have to be dealt with when looking to see if packets have been acked. And unsent packets don't have to be timed out.

If things go as planned the :write_protocol word places the pep into the unsent list. The transmit task takes it out of the unsent list, sends it and places it in the sent list. The proto task accpets incoming datagrams. The incoming datagrams ack data sent. The ack operation results in packets in the sent list being taken out and returned to the free buffer pool.

The other end advertises a maximum window size. This is nice, but only places a liumit on what is inflight.

We limit the number of peps that can be queued for transmission. This is done to protect ourselves from excessive data generation. 

 
		#queue_list_length
		_#transmit_queue_priorities *
		#queue_data_length + bytes% instance_variable %%tcp_queue_unsent 
		
		#queue_list_length
		_#transmit_queue_priorities *
		#queue_data_length + bytes% instance_variable %%tcp_queue_sent
pep packets received from other end

Received peps are linked in here in sequence number order. If the data is received multiple times it will be queued here multiple times. 

 
		cell% instance_variable %%receive_list

The variable is descremented as data added to list incremented as data is removed. When it decrements to zero the buffer is about full. Packets that contain the current rcv.nxt sequence number can also be added. 

 
		cell% instance_variable %%receive_list_room
data areas, inspired by rfc793

The seqence number of incoming datagram effects these areas.

When sending a datagram we use these ares to supply the window and ack value. The ack value reflects the current value of rcv.nxt

Segence numbers below the value stored here have been read by the application are are no longer the problem of the TCP sub system. 

 
		cell% instance_variable %%tcp_rcv.used

Next seqence to be received. Sequence numbers equal or greater than this have not been received. Sequence numbers less have been received. The syn segment received from the remote machine sets the initial value.

Remember the syn flag occupies one byte of the segment space, as does the fin flag. 

 
		cell% instance_variable %%tcp_rcv.nxt

This is the end we are allowed to advertise up to. There should be a "we have advertised up to variable" as well. As the "can advertise" and "have advertise" occure at different times. Some of the data sent by the other end has to be within the advertised window to be accepted. We use the value contained in this variable, very little is gained by being pedantic. We will accept data past the window as long as the datagram contains some data within the window. 

 
		cell% instance_variable %%tcp_rcv.end
			 
 
		cell% instance_variable %%tcp_rcv.iss
Sending sequences

Initial send sequence; set on open. 

  
		cell% instance_variable %%tcp_snd.is

The highest value ack I have received from other end. Remember this is equal to data seen by other end plus one. Or to put it another way, the sequence number of the packet seen by the other end plus the amount of data contained in the packet. 

 
		cell% instance_variable %%tcp_snd.una

The highest sequence I have sent.plus one, or the first unsent sequence depending on you point of view. Data with sequence numbers less than this will be on the sent queue, data with sequence numbers higher or equal will be on the unsent queue. I get a bit upset if other ends start acking unsent data. 

 
		cell% instance_variable %%tcp_snd.nxt

The ack and window received in the incoming packet has a big effect on these. The last sequence plus one that we may send. This is equal to the ack + ack_window received in the incoming data. 

 
		cell%  instance_variable %%tcp_snd.end

The seqence used to queue data 

 
		cell% instance_variable %%tcp_snd.queue

Congestion window. The end.seq is set by the remote end. Each packet contains a window and this along with the ack value is used to set seq.end

The congestion window is controlled by us. If packets sent arn't acked we conclude the losses were caused by congestion and reduce the congestion window. 

 
		cell% instance_variable %%tcp_snd.congestion.wnd

%%tcp_snd_mss is set to default in construct, and if not told otherwise it is limited to the tcp defualt. %%tcp_snd_mss can be updated by an option in the tcp header received form other end. 

 
		cell% instance_variable %%tcp_snd.mss

The receive segment size is sent by us as an option in the syn message We determine the rcv.mss on object create. It is not altered thereafter. If we are sending to something behind a gateway we set it to a value equal to the tcp default. If we are talking to something on the same network segment we set a value based on the interfaceces maximum transfer unit 

 
		cell% instance_variable %%tcp_rcv.mss

A variable set in the proto task and reset in the transmit task. The proto task sets the variable if an ack is required. The transmit task resets it when a ack has been sent. 

 
		cell% instance_variable %%tcp_send_ack

If the task consuming the TCP data wants data and none is available this variable will be set. 

 
		cell% instance_variable %%receiving_task

An address of a string desribing why the link aborted is stored here 

 
		cell% instance_variable %%tcp_abort_reason

When communication is started the inital seqence number has to be dependent on a clock. 

 
		: initial_sequence ( -- num )
			@ticks _#tcp_ticks>ticks * 
			_wreg_TCN1 W@ _#tcp_ticks>ticks _#trr1_value */ + 
		;
			 
 
		m: ( parent --)
			this [parent] :construct
			zero %%remote_port !
			zero %%local_port !
			zero %%demux_structure !
			zero %%tcp_state_error !

			\ the timeout variables; we pretend we have had very
			\ stable transmission at the set timeout. 
			#rexmt_default_value %%tcp_rexmt !
			#rexmt_default_value %%tcp_rtt !
			#rexmt_default_value %%tcp_rtt_smooth !
			zero %%tcp_rtt_dev !


			#tcps_closed %%tcp_state !
			\ it transmit queues
			_#transmit_queue_size  
			_#transmit_queue_priorities 
			%%tcp_queue_sent queue_init
			
			_#transmit_queue_size  
			_#transmit_queue_priorities 
			%%tcp_queue_unsent queue_init	
	

			\ %%transmit_link doesn't have to be initialised
			\ %%transmit_time doesn't have to be initalised
			FALSE %%transmit_in_list !


			zero %%receive_list !
			#rcv_data_buffer %%receive_list_room !


			\ when we receive the remote syn this will be set 
			\ to valid value
			zero %%tcp_rcv.nxt !
			zero %%tcp_rcv.used !
			#rcv_data_buffer %%tcp_rcv.end ! 


			\ %%tcp_snd.end doesn't have to be initialised
			initial_sequence DUP %%tcp_snd.is !
			
			\ the sync has not been acknowledged.
			DUP %%tcp_snd.una !
			\ skip the SYN value, it will get sent because of the state.
			1+
			DUP %%tcp_snd.nxt !
			DUP %%tcp_snd.queue !
			\ we have received no reply, the window needs to be large enough
			\ to send the syn and that is it
			%%tcp_snd.end !

			\ we start up assumeing link congestion
			#default_mss %%tcp_snd.congestion.wnd !
			
			\ hopefully the incoming syn value will contain an option that
			\ will set this.
			#default_mss %%tcp_snd.mss !
			#default_mss %%type_buffer_size !

			\ we set this and tell other end about it when we send the SYN
			#default_mss %%tcp_rcv.mss !


			\ don't need to stack with an ack
			FALSE %%tcp_send_ack !

			\ no task is waiting for recevied data
			zero %%receiving_task !
			zero %%tcp_abort_reason !

		; overrides :construct
support words for trasmit task

The transmit list is a linked list of io objects. They are linked in timeout order.

The receive routine doesn't even try and guess what the transmit routine should send. The receive routine ( which is a proto object executed by the ptroto task) updates the data area and schedules transmit events. The transmit routines determine what is to be sent.

The client task ( the task using the TCP object queues paskets for transmission by the tranmission task, and schedules the tranmission task.

tcp opjects that want the tranmission task to look at them link themseleves into the follwoing list. 

 

		ram_variable %tcp_transmit_head

tcp_transmit can only be used within methods. The transmit task is executed every time the tcp level is run, so it has to be pretty efficiant. The list is kept in time sorted order. If the first item has timed out it is removed from the list and the :transmit_action method is executed. :tranmit_action may place the object back in the list. When the :trasmit method is finished the transmit task looks at the list again and sees if the top entry has timed out.

The tcp_transmit_task is ran before the routing task so messages can be on the wire after one pass through the tcp level.

tcp_transmit takes a time. If you set time to xclock+ @ the tcp level will be scheduled directly, and the entry will timeout, this is used for data transmits. If you set time to xclock+ @ 1+ a reschedule will not occure, but the entry will timeout on the next clock interrupt. Ack should be rescheduled in this way. In fact it is probable better to add 5, we allow a pretty big window, and allow 50 msec before a ack is sent. This gives things time to consume data allowing the sending of a ack that better reflect the current window size.

5 is picked as follows

10 Mbits approximatly 1 Mbyte. 1/20 sec = 50k bytes, this will fit in a 64k window. To be working at this speed we are talking on the local net. So responce will be seen almost directly.

On a slow link the delay means very little.

Objects can be added to the transmit list at any level.

Word executed to schedule a transmit event. 

 

		: tcp_transmit ( time --)
			_lock_word
			BEGIN 
				%%transmit_in_list @ IF
					\ if greater
					DUP %%transmit_time @ - 0> IF
						\ new time is greater than old; transmit is scheduled
						\ sooner than new request so drop this one. If you delay acks
						\ by 5, first ack will get scheduled, the rest (  until the ack is
						\ sent)  will pass through here.
						DROP
						_unlock_word
						EXIT
					THEN
					\ this will unlock. We have to unlink as the
					\ list has to be linked in timeout order and we are
					\ about to change the timeout value.
					FALSE %%transmit_in_list !
					%%transmit_link unlink_double
					\ There is a risk that a higher priority task will
					\ link in after we unlink and before we get the 
					\ lock back on, if this happens we just have to 
					\ go around again.
					_lock_word
				THEN
				%%transmit_in_list @ not
			UNTIL
			\ time(--
			\ The lock should be on here
			\ with the object not linked into the transmit list
			DUP %%transmit_time !
			TRUE %%transmit_in_list !
			%tcp_transmit_head
			BEGIN
				\ time link(--
				DUP @
				\ time link link_next(--
			WHILE
				\ time link(--
				2DUP 
				\ time link time link(--
				@ [ %%transmit_time %%transmit_link - ]T LITERAL + @
				\ time link time_new time_old(--
				- 0< IF
					\ next entry is furthur in time so link one back
					\ this word will unlock
					%%transmit_link SWAP link_double
					\ time(--
					xclock- @ + 0< IF
						\  work is to be done now. This word causes a trap. If we are on 
						\ the lowest level the priority will now be raised and tcp
						\ trasmit and route will do there thing. If we are running
						\ at a high priority this will do no more than schedule the
						\ tcp level for a run when priorities fall.
						run_tcp
					THEN 
					EXIT
				THEN
				@ \ next entry
			REPEAT
			\ time link(--
			\ come to end of list
			%%transmit_link SWAP link_double 
			xclock- @ + 0< IF
				run_tcp
			THEN 
		;

		: _setup_tcp_packet { ( seq rcv.wnd rcv.nxt ) variable %flags variable %pep -- }
			%%local_machine @ %%remote_machine @ 
			zero ( ip_option_length) %pep @ 
			\ seq rcv.wnd rcv.nxt source destination ip_option_count pep(--
			setup_ip
			\ the priority and tos is set to zero. This determines
			\ how %%priority is used. It contains the data encoded as required 
			\ for a direct store into the tcp packet.
			%%priority @ %pep @ [ ep_data ip_tos + ]T LITERAL + B!
			\ seq rcv.wnd rcv.nxt(--
			\ set tcp protocol
			IPT_TCP %pep @ [ ep_data ip_proto + ]T LITERAL  + B!
			#tcp_header_end %pep @ add_to_ip
			%pep @ ep_ipdata + @ 
			\ snd.una rcv.wnd rcv.nxt ip_data(--
			%%local_port @	OVER #tcp_src + W!
			%%remote_port @ OVER #tcp_dst + W!
			SWAP OVER #tcp_ack + !
			\ seq rcv.wnd ip_data(--
			SWAP OVER #tcp_window + W!
			\ seq ip_data(--
			SWAP OVER #tcp_seq + !
			\ ip_data(--
			[ #tcp_header_end 2 RSHIFT ( to 32 bit words) 
			4 LSHIFT ( top 4 bits ) ]T LITERAL
			OVER #tcp_offset + B!
			\ ip_data(--
			%flags @ OVER #tcp_flags + B!
			\ ip_data(--
			zero OVER #tcp_urgptr + W!
			\ ip_data(--
			DUP #tcp_header_end + %pep @ ep_protodata + !
			zero %pep @ ep_protocount + !
			\ the protocol object for checksum latter in the datgrams life.
			_%tcp_object @ %pep @ ep_proto_obj + !
			\ ipdata(--
			DROP
		;

We call this if we want to add the mss to a packet. it is usable with a pep that contains data. The pep has to be long enough to allow us to insert the 4 bytes. If data is present we do have to move it to insert the option. In this implementaton we only send the mss in the syn segment and we do not send data in the syn segment. 

 
		: _set_tcp_option { variable %pep -- }{

					2 CONSTANT #mss_option_code

					\ describe the mss option
					0 
					DUP CONSTANT _#code  1+
					DUP CONSTANT _#len   1+
					DUP CONSTANT _#data  2+ 
					DUP CONSTANT _#opt_length DROP

					#tcp_header_end 4 +  2 RSHIFT ( to 32 bit words) 
					4 LSHIFT ( top 4 bits ) CONSTANT _#header_length 

			}

			\ add_to_ip does not alter the protocol counts and nor should it, 
			\ there are a lot of reasons for adding to the datagram that have 
			\ nothing to do with the protocol
			_#opt_length %pep @ add_to_ip
			%pep @ ep_protodata + @ DUP _#opt_length + %pep @ ep_protocount + @ MOVE
			\ protodata(--
			_#opt_length %pep @ ep_protodata + +! 
			%pep @ ep_ipdata + @
			\ ipdata(--
			_#header_length OVER #tcp_offset + B!
			\ write the option data
			#mss_option_code OVER #tcp_header_end + _#code + B!  
			_#opt_length OVER #tcp_header_end + _#len + B!	
			%%tcp_rcv.mss @ SWAP #tcp_header_end + _#data + W!
			
		;

We create the pep and queue it as an ip. 

 
		: _send_empty_segment { ( seq rcv.wnd rcv.nxt )  variable %flags -- }{
					
				variable %pep 
				
				\ describe the mss option
				0 
				DUP CONSTANT _#code  1+
				DUP CONSTANT _#len   1+
				DUP CONSTANT _#data  2+ 
				DUP CONSTANT _#opt_length DROP
			
				
				
			}
			zero %flags @ #tcpf_syn AND IF
				\ if a syn packet we have to leave room for an option.
				_#opt_length +
			THEN
			[ ep_data ip_options #tcp_header_end + + ]T LITERAL +
			['] get_free_buffer CATCH IF
				\ snd.nxt rcv.wnd rcv.nxt length(--				
				2DROP 2DROP
				EXIT
			THEN
			%pep !
			\ snd.nxt rcv.wnd rcv.nxt(-- 
			%flags @ %pep @ _setup_tcp_packet
			%flags @ #tcpf_syn AND IF
				%pep @ _set_tcp_option
			THEN
			%pep @ queue_ip
		;


		: _send_an_ack ( --)
			%%tcp_snd.nxt @ \ next seq to send
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			\ We will accept past end and it can happen
			\ if the sending stack sends the complete segment on spec.
			zero MAX
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_ack _send_empty_segment
		;


		\ receiving task will be asleep if waiting for data
		: _wake_receiving_task ( --)
			_lock_word
			%%receiving_task @ IF
				wake %%receiving_task @ W!
				zero %%receiving_task !
			THEN
			_unlock_word
		;	



		: _return_transmit_queues ( --)
			BEGIN
				%%tcp_queue_sent dequeue ?DUP
			WHILE
				kill_free_buffer
			REPEAT
			
			BEGIN
				%%tcp_queue_unsent dequeue ?DUP
			WHILE
				kill_free_buffer
			REPEAT

		;

		: _return_receive_list ( --)
			BEGIN
				_lock_word
				%%receive_list @ ?DUP
			WHILE
				\ this will unlock
				DUP unlink_double
				kill_free_buffer
			REPEAT 
			_unlock_word
		;

The time wait state is looked after by tcp_demux. This word sets things up 

 
		: _setup_time_wait ( time --)
			\ amount of time we are to stay in the timewait state
			%%demux_structure @ _#demux_live_time + !
			\ the time we entered the state
			xclock+ @ %%demux_structure @ _#demux_time + !
			\ we are in this state if the object is zero
			0 %%demux_structure @ _#demux_object + !
		;

If you close without doing a flush file; the file will be flushed and the fin flag will get set as part of last packet. It is done this way so short transactions can be done in 5 packets, with the client left in the time wait state. 

			SYN                 client
			SYN ACK             server
			ACK DATA FIN        cleint
			ACK DATA FIN        server
			ACK                 client
			
 
		: _send_fin_packet ( --)
				%%type_buffer> @ IF
					\ still data to be sent
					%%type_buffer> @ 			
					[ #tcp_header_end ]T LITERAL -
					\ tcp_header(--
					#tcp_flags + DUP B@ #tcpf_fin OR SWAP B!
					this :flush_file
				ELSE
					\ queue a fin packet.
					[ ep_data ip_options #tcp_header_end + + ]T LITERAL get_free_buffer
					DUP this :setup_protocol
					\ addr(--
					DUP ep_ipdata + @ #tcp_flags + DUP B@ #tcpf_fin OR SWAP B!
		
					\ addr(--
					0 0 ROT this :write_protocol
				THEN
		;

		m: ( --)
			\ there is a timer routine to delete TCP demux
			\ entries. We have to have this because the deletion
			\ of the entry has to be delayed if we send the fin first.

			\ If demux structure is set to zero we are closing bacause
			\ of an abort in Sopen
			%%demux_structure @ IF
				zero  \ time to leave the finwait state open
				%%tcp_state @ DUP #tcps_established = 
				SWAP #tcps_synrcvd = OR IF
					\  shutdown requires 
					\ a little chat with other end.
					xsleep
					@u activation_status %%receiving_task !
	
					#tcps_finwait1 %%tcp_state !
					_send_fin_packet
					
					xnext
					\ we should now be in the time_wait state
					#time_wait_delay +
				THEN
				%%tcp_state @ #tcps_closewait = IF
					xsleep
					@u activation_status %%receiving_task !
					 \ other end has sent a fin
					 \ we must now send our fin and wait for ack
					#tcps_lastack %%tcp_state !
					_send_fin_packet
					xnext
				THEN
				\ if we wake here we have received the ack
				\ we can close directly
				\ The time value is how long the demux entry should
				\ servive
				\ time(--
	
				\ we should be in either #tcps_time_wait, #tcps_closed, or listen
				\ but we are not going to look
				\ time(--
				\ if we get here the close has finished from out point of view
				_setup_time_wait
				\ now no more packets will arrive from net
				\ now get us out of the transmit list
				_lock_word
				%%transmit_in_list @ IF
					%%transmit_link unlink_double
				THEN
				_unlock_word
				\ now no more packets will be sent to the net.
				_return_transmit_queues
				_return_receive_list
			THEN
			this [parent] :destruct
		; overrides :destruct

String can be: 

 
		 /destination_machine/destination_port 
		//destination_port
		or nothing

The mode determines the priority and the type of service required. 

 
		m: ( addr n mode -- instance )
			DUP %%mode !
			\ the mode contains the priority and mode as required
			\ for tcp header
			%%priority !
			\ /machine/port
			[CHAR] / remove_leading
			[CHAR] / left_split 
			\ addr_machine count_machine addr_port count_port(--
			2SWAP DUP IF \ machine specified
				Sresolve_address %%remote_machine !
			ELSE
				2DROP
			THEN
			\ addr_port count_port(--
			[CHAR] / remove_leading
			DUP IF \ port speced
				Snumber %%remote_port !
			ELSE
				2DROP
			THEN
			\ ask the os for a demux entry, this also provides a local port
			\ as soon as we do this we can start receiving 
			\ datagrams destined to the allocated port.
			\ As no one knows about us it is not likely, but it
			\ is possible.
			\ This adds to the udp demux table.
			\ We are a client, we care about detination machine and port
			this 
			%%remote_machine @ -1 
			%%remote_port @ -1
			_tcp_port %%demux_structure !
			%%demux_structure @ _#demux_local_port + @ %%local_port !
			\ find out if remote machine on local net; 
			%%remote_machine @ 
			%%priority $1C AND 2 RSHIFT 
			route_get ?DUP IF
				\ the standard calls for this; not really needed but 
				\ what the heck
				DUP rt_interface + @ :ip @ %%local_machine !
				\ The rules are. Make the receive mss as big as you can 
				\ and tell the other end when you send the sync. The send
				\ mss is the default value unless the other end tells us 
				\ otherwise. The mss depend not only on the connection medium 
				\ but alsp on the host being communicated with. The other end
				\ may not be able to handle a mss greater than the min.
				DUP rt_gw + @ not IF
					\ we are talking locally; make mss dependent
					\ on mtu. This is very important for us as the
					\ rti bus has a mtu of 8k
					\ see rfc879 page 5 for justification for this calculation
					DUP rt_interface + @ :@mtu ip_options - 
					#tcp_header_end - %%tcp_rcv.mss !
				THEN
				DROP
			THEN
			#tcps_synsend  %%tcp_state !

			\ This adds the object to the transmit list. After this
			\ things are started
			\ the TCP/IP system is trying to get the SYN packet out, and will deal with
			\ the ack received.
			xclock+ @ tcp_transmit
			this
		; overrides :Sopen

Back when the file objects were being written the object :construct word was was split from specific action need to open the file, and Sopen was born. Well this came in handy. When a server creates a client it is just creating one of these objects. We need a word to do the action Sopen does based on data received. :client_init is the word.

The SYN buffers contain a head structured as shown below 

 
		zero 
		DUP CONSTANT _#lhead_link_fwd      4+
		DUP CONSTANT _#lhead_linh_back     4+
		DUP CONSTANT _#lhead_entries_added 4+
		DUP CONSTANT _#lhead_data
		DROP

Each syn received creates an entry as described below. The timeout routine deletes entryies. 

 
		zero 
		DUP CONSTANT _#listen_inuse       2+
		DUP CONSTANT _#listen_port        2+
		
		DUP CONSTANT _#listen_mss         2+
		\ service type
		DUP CONSTANT _#listen_st          2+
		
		DUP CONSTANT _#listen_machine     4+
		DUP CONSTANT _#listen_time        4+
		\ sequence that came in packet
		DUP CONSTANT _#listen_rcv.iss     4+
		\ sequence that we sent
		DUP CONSTANT _#listen_send.iss    4+
		CONSTANT _#listen_entry_size

addr points to a table contructed as above the pep points to the datagram that can move the client to the established state. We do the movement using the standard receive words because the pep can contain data and a fin flag as well as a syn and a ack of our syn and it is all to complicated to write again. 

 
		ram_variable %tcp_server_error

		CREATE _$bad_open_packet ," Bad open packet"
		m: { variable %pep variable %syn_table (  -- ) }
			%syn_table @ _#listen_machine + @ %%remote_machine !
			%syn_table @ _#listen_port + W@ %%remote_port !

			%pep @ [ ep_data ip_dst + ]T LITERAL + @ %%local_machine !
			%pep @ ep_ipdata + @ #tcp_dst + W@  %%local_port !

			%syn_table @ _#listen_mss + W@ %%tcp_rcv.mss !
			
			\ I received the syn, I expect to see the seqence after the syn
			%syn_table @ _#listen_rcv.iss + @ 
			DUP %%tcp_rcv.iss !
			DUP %%tcp_rcv.used !

			1+  
			DUP %%tcp_rcv.nxt ! 
			#rcv_data_buffer + %%tcp_rcv.end !
			
			\ I have sent the SYN 
			%syn_table @ _#listen_send.iss + @ 
			DUP %%tcp_snd.is !
			DUP %%tcp_snd.una !
			DUP %pep @ ep_ipdata + @ #tcp_window + W@ + %%tcp_snd.end !

			1+ 
			DUP %%tcp_snd.nxt !
			%%tcp_snd.queue !
			\ Set link to priority and tos requested by client.
			%pep @ [ ep_data ip_tos + ]T LITERAL + B@ %%priority !
			\ set the %%local_machine, it is dependent on the 
			\ address received in the syn datagram, not the
			\ interface the reply is sent.


			
			\ set up the demux entry
			\ we care about all values
			this  %%local_port @ 
			%%remote_machine @ -1 %%remote_port @ -1
			_tcp_add IF
				\ we are in deep shit we can't use the client and we can't close it
				\ The routine that gets the client_object will have to check that this
				\ is non zero. If zero it will have to close it directly.
				zero %%demux_structure !
				%pep @ kill_free_buffer
				EXIT
			THEN
			%%demux_structure !

			#tcps_synrcvd %%tcp_state !
			\ so the packet gets used twice, the server object
			\ deals with the packet and creates a client object
			\ the client object is put into the state in which
			\ this packet is expected and it uses the packet again.
			\ If you look at the client code it can deal with stange 
			\ combinations of ack data and fin,
			%pep @  this :consume_port
			%%tcp_state @ #tcps_synrcvd @ > not IF
				\ if the state is not above #tcps_synrcvd then
				\ we have to close the link down again.
				\ This should not happen!
				1 %tcp_server_error +!
				_$bad_open_packet this :abort_connection
			THEN
			\ well that is it folks.
		; overrides :client_init



		: _add_to_tcp ( n  pep  -- ) 
			2DUP add_to_ip
			ep_protocount + +!
		;
			

		\ 
		\ 
		m: { variable %pep -- }
			\ don't set the ack bit cause it is not a valid ack unless
			\ the ack and window fields are updated
			%%tcp_snd.queue @ 0 0 #tcpf_ack %pep @ _setup_tcp_packet
		; overrides :setup_protocol

		\ not a valid ooption
		m: ( %pep_in %pep_out -- )
			TRUE ABORT" Not a valid option"
		; overrides :setup_protocol_from_pep

The big qestion; should We close on an abort or leave it to the user. The rule is if you take one of these words you can convert it into a ior type result with a simple catch. That means you don't close

While TCP presents itself to the application as a byte stream, at the low level this sytems deals in peps. :read_protocol fetches the next pep. This word deals with overlapping data, and removes urgent data from the input stream. 

 
		: _new_data?  { ( pep -- addr count true | false ) }{
				variable %urgent_pointer }
			\ adjust datagram so urgent data is skipped
			DUP ep_ipdata + @ #tcp_urgptr + W@
			OVER ep_protocount + @ MIN
			\ pep urgent(-- 
			2DUP SWAP ep_protodata + +!
			2DUP NEGATE SWAP ep_protocount + +!
			OVER ep_start_seq + +! 


			%%tcp_rcv.used @  
			OVER ep_end_seq + @
			- 0< IF
					\ pep (--
					\ move past data in packet already seen
					%%tcp_rcv.used @ 1+ OVER ep_start_seq + @ -
					\ if urgent data is skipped result will be negative.
					\ if result is negetive nothing has to be altered.
					zero MAX
					\ pep num_used(--

					SWAP 2DUP ep_protodata + @ +
					\ num_used pep addr(--
					-rot
					ep_protocount + @ SWAP - 
					DUP IF
						TRUE
						EXIT
					ELSE
						2DROP
						FALSE
					THEN
			THEN
			\ pep(--
			DROP
			FALSE
		;



		\ can't receive data in listen state
		\ can't receive after you have closed
		\ you  can still receive after other end has received
		\ fin as received data has to be taken out of queue
		\ So there us not many states left.
		: _bad_receive_state? ( -- flag )
			\ deal with common case as directly as possible
			%%tcp_state @ #tcps_established = IF
				FALSE
				EXIT
			THEN
			%%tcp_state @ DUP #tcps_synsend = IF
				DROP FALSE
				EXIT
			THEN
			DUP #tcps_synrcvd = IF
				DROP FALSE
				EXIT
			THEN
			#tcps_closewait = IF
				FALSE
				EXIT
			THEN
			TRUE
		;

		: _update_rcv_window ( --)
			_lock_word
			%%tcp_rcv.nxt @ %%receive_list_room @ + DUP 
			%%tcp_rcv.end @ %%tcp_rcv.mss @ +
			- 0> IF
				%%tcp_rcv.end !
			ELSE 
				DROP
			THEN
			_unlock_word
		;

		m:  { ( --pep addr n ) }{
			variable %pep
			}
			\ set up for the xnext
			BEGIN
				%%timeout @ IF
					xtest
				ELSE
					xsleep
				THEN
				\ the order you do this sort of thing is important.
				\ you have to set yourself up for activation
				\ before you see if the other task has done something.
				@u activation_status %%receiving_task !

				\ check to see if we are in a valid state.
				%%tcp_state @ #tcps_abort = IF
					0 %%receiving_task !
					%%tcp_abort_reason @ $ABORT
				THEN
				_bad_receive_state? IF
					0 %%receiving_task !
					0 0 0 
					EXIT
				THEN
				%%receive_list @ IF
					_lock_word
						%%receive_list @ 
						DUP unlink_double
					_unlock_word
					\ pep(--
					\ we have to do this first as system queues peps 
					\ that have nothing more than a ep_error value
					DUP ep_error + @ IF
						\ ICMP messages are not seen here
						DUP ep_error + @
						SWAP kill_free_buffer
						zero %%receiving_task !
						$ABORT
					THEN
					\ we have to increase %%receving_list_room, if the available 
					\ room is now bigger than mss we send an ack to tell the other end
					\ the window is now open, a winder advertisment.
					%%receive_list_room @ %%tcp_rcv.mss @ < IF

						_lock_word
						DUP ep_protocount + @ %%receive_list_room +!
						_unlock_word
						_update_rcv_window

						%%receive_list_room @ %%tcp_rcv.mss @ < not IF
							\ should we send ack directly or should we queue.
							\ If we queue............
							\ If data is being sent in the
							\ other direction then this will only alter the time.
							\ If the link is quite then it is an additional overhead.
							\ TRUE %%tcp_send_ack !
							\ xclock+ @ tcp_transmit		
							\ If we ack directly.............
							\ The software load is less. If data is being sent then it
							\ is an extra packet. I don't know, neither is the better choice.
							_send_an_ack
						THEN
					ELSE
						_lock_word
						DUP ep_protocount + @ %%receive_list_room +!
						_unlock_word
						_update_rcv_window

					THEN
					\ pep(--	
					DUP _new_data? 
					\ pep addr num true|pep false(--
					IF
						\ we have new data
						jump ep_end_seq + @ %%tcp_rcv.used !
						zero %%receiving_task !
						EXIT
					THEN
					\ buffer added nothing new
					\ try again
					\ This is where we deal with 
					\ double copies of received data.
					kill_free_buffer
				THEN
				\ If we are in close wait and there is no data
				\ in the list then reception has finished
				%%tcp_state @ #tcps_closewait = IF
					0 %%receiving_task !
					0 0 0 
					EXIT
				THEN
				\ this sets the timeout time and does a xnext.
				\ it the status is set to xsleep setting the 
				\ timeout time is a null operation
				%%timeout @ xwait
				xtimeout? IF
					0 %%receiving_task !
					0 0 0 
					EXIT
				THEN
			AGAIN 
		; overrides :read_protocol
		
		: _read_active ( --)
			%%active_pep @ IF
				%%active_pep @ kill_free_buffer
			THEN
			this :read_protocol
			%%active_count !
			%%active_pointer !
			%%active_pep !
		;

As we read in data we increase addr and decrease num. Our aim here is speed 

 
		: _read_binary_stream ( addr1 num1 -- addr2 num2 flag)
			%%active_count @ 
			OVER > IF
				\ addr1 num1(--
				\ the data request can be satisfied with data over
				2DUP %%active_pointer @ SWAP MOVE
				\ addr num (--
				DUP NEGATE %%active_count +!
				DUP %%active_pointer +!
				+ zero
				\ can be end of stream all the data isn't read from the pep 
				FALSE
				EXIT
			THEN
			\ move what we have in pep
			\ if the fin flag is set well 
			\ this is just all you are going to get
			\ addr1 count(--
			%%active_pointer @ jump %%active_count @ MOVE
			%%active_count @ -
			\ addr1 stil_to_get(--
			SWAP %%active_count @ + SWAP
			\ addr2 still_to_get(--
			%%active_pep @
			\ addr still_to_get pep(--
			zero %%active_pep !
			zero %%active_count !
			DUP ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
				TRUE
			ELSE
				FALSE
			THEN
			SWAP kill_free_buffer
		;

		: _read_tcp  { ( addr len -- len) }{
				variable %len }
			DUP %len !
			BEGIN
				\ go in circles until
				\ we have requested data
				\ or until closed by other end
				\ remember read assumes no data structure
				\ we will return with the count
				\ unless channel is closed in which case
				\ we return with less than count
				%%active_count @ not IF
					_read_active
					%%active_pep @ not IF
						\ timeout was set, and we timed out
						NIP
						%len @ SWAP - 
						EXIT
					THEN
				THEN
				\ addr len(--
				_read_binary_stream
				\ addr len flag(--
				\ if flag is true stream is finished
				IF
					NIP
					%len @ SWAP -
					EXIT
				THEN
				\ else num should be zero
				DUP not IF
					2DROP %len @
					EXIT
				THEN
			AGAIN
		;


		m:  ( addr len -- len)
			_read_tcp
		; overrides :read


		: eot?  ( char -- flag )		
			%%eot #$count_length + %%eot $count@ zero DO
			\ char addr (--
			2DUP char@ = IF
				2DROP
				TRUE
				UNLOOP
				EXIT
			THEN
			1 CHARS +
			LOOP \ char addr(--
			2DROP
			FALSE
		;

A termination code has to be stored at the end of the input. Num2 will never equal num1. This differs from ANSI forth, if we followed the standard the user would have to make the buffer 1 ( the standard requires two) characters longer that num1. I think that is absolute nonsence designed to cause programming bugs. 

 
		: _get_a_character ( -- char)
			%%active_pointer @ char@
			1 CHARS %%active_pointer +!
			[ 1 CHARS NEGATE ]T LITERAL %%active_count +!
		; 
		
		: _store_a_char ( addr num char --addr num)
			DUP #lf = IF
				DROP
				EXIT
			THEN
			jump char!
			SWAP
			1 CHARS +
			SWAP 
			1 -
		;

		: _unget_character ( char --)
			DROP
			1 CHARS %%active_count +!
			[ 1 CHARS NEGATE ]T LITERAL %%active_pointer +!

		;
			 
			1) slow as a wet wig as each character has to be looked at.
			2) Assumptions are made on character set and size.

And lets be honest about this, these have to be the same as the assumtions made by unix if you are going to get involved in the internet. 

 
			1) slow as a wet wig as each character has to be looked at.
			2) Assumptions are made on character set and size.
			3) telnet assumptions made

Flag is true if the data stream is finished. 

 
		: _get_data ( -- term true | char false)
			%%active_count @ not IF
				\ look at the fin flag for the last pep.
				%%active_pep @ IF
					\ addr pep(--
					%%active_pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
						\ addr pep(--
						%%active_pep @ kill_free_buffer
						0 %%active_pep !
						\ addr(--
						#end_eof TRUE
						EXIT
					THEN
				THEN
				\ have to get more data into buffer
				_read_active 
				%%active_pep @ not IF
					\ if we returned without a pep we are finished
					#end_eof TRUE
					EXIT
				THEN
			THEN
			_get_a_character 
			FALSE
		;


		: _read_terminal_stream { ( addr1 num1 -- addr2 num2 ) }{
			}
			BEGIN
				\ addr1 num(--
				\ if the count is one of the termination count
				\ we cannot use it, we have to leave room for the
				\ terminator that indicates we ran out of room.
				\ addr num(--
				_get_data IF
					\ a terminator
					_store_a_char
					EXIT
				THEN
				\ addr num char(--
				DUP eot? IF
					\ addr num char(--
					_store_a_char
					\ addr num (-- 
					EXIT
				THEN
				\ leave room for terminator
				OVER 2 < IF
					_unget_character
					\ addr num (--
					#end_count _store_a_char
					EXIT
				THEN	
				\ addr num char(--
				_store_a_char
			AGAIN
		;




		m:  { ( addr len -- len flag) }{
				variable %len 
				variable %addr }

			\ zero is a problem as we need room to store the terminator
			DUP not IF
				2DROP zero TRUE 
			THEN

			DUP %len !
			OVER %addr !

			\ addr len(--
			_read_terminal_stream
			\ addr1 len1(--
			NIP %addr @ SWAP
			\ addr len1(--
			%len @ SWAP - 
			\ addr len3(--
			this :termination>code
			\ len4 flag(--
		; overrides :read_line

		

		m: ( addr num --num flag)
			1- TUCK + char@ 
			#end_eof = IF
				FALSE
			ELSE
				TRUE
			THEN
		; overrides :termination>code

Write the data pointed to by addr and n to the pep and queue. Queued data is only sent from four states. 

			SYN-SENT
			SYN-RECEIVED
			ESTABLISHED
			and CLOSE-WAIT

If you queue in other states the queue will become full and you will sleep forever. It is probable best to abort if we are not in a valid state. 

 
		: _bad_send_state? ( --flag)
			\ most common
			%%tcp_state @ #tcps_established = IF
				FALSE EXIT 
			THEN
			\ occures if other end has closed and
			\ is waiting for us to stop yaddering
			%%tcp_state @
			DUP #tcps_closewait = IF
				DROP FALSE EXIT 
			THEN
			\ getting in a bit fast. Opening hasn't finished.
			\ However queueing data is acceptable.
			DUP #tcps_synsend = IF
				DROP FALSE EXIT 
			THEN
			DUP #tcps_synrcvd = IF
				DROP FALSE EXIT 
			THEN
			\ so we can send the fin
			DUP #tcps_finwait1 = IF
				DROP FALSE EXIT
			THEN
			\ se we can send the fin
			#tcps_lastack = IF
				FALSE EXIT
			THEN
			TRUE
		;

Write the data into the pep and queue the pep for transmisison. It is assumed that the pep has been properly set up. 

 
		m: { ( addr n) variable %pep ( --) }
			_bad_send_state? ABORT" Can't transmit data with link in this state" 
			\ add_to_ip can deal with zero.
			\ add n (--			
			DUP %pep @ _add_to_tcp
			\ MOVE can deal with a zero count
			\ and common destination and source address
			%pep @ ep_ipdata + @ #tcp_header_end + SWAP MOVE
			\ we now have to get the end sequence from the pep
			\ as the fin flag may be set.
			%pep @ _end_sequence 1+
			\ seq(--
			%pep @ %%tcp_queue_unsent zero
			\ address queue_head prority(--
			\ this gets the data onto the queue.
			enqueue_wait
			\ seq (--
			%%tcp_snd.queue !
			\ We need to transmit directly
			\ even if there is already data in the trasmit queue we may be able
			\ to send the new data directly as there can be more than one packet 
			\ in flight.
			xclock+ @ tcp_transmit		

		; overrides :write_protocol

Write buffered data to storage if you follow write through you will find our buffer is the pep and there is no need to transfer the data. If you look at the definition of MOVE you will see it is bright enough not to move data that has a common source and destination address. 

 
		m:  \ compile time ( --xt)
			\ runtime ( --)
			%%type_buffer> @ ?DUP IF 
				%%type_buffer_count @ OVER
				[ ep_data ip_options #tcp_header_end + + ]T LITERAL -
				this :write_protocol
			THEN
			zero %%type_buffer> !
			zero %%type_buffer_count !
			
		; overrides :flush_file

Keep going around until count is zero, each time around we send a little more data. 

 
		: _tcp_data>type_buffer ( addr count -- false|addr count true)
			%%type_buffer> @ not IF
				%%type_buffer_size @ 
				[ ep_data ip_options #tcp_header_end + + ]T LITERAL + get_free_buffer
				DUP this :setup_protocol
				ep_ipdata + @ #tcp_header_end +
				%%type_buffer> !
				zero %%type_buffer_count !
			THEN
			\ addr count(--	
			%%type_buffer_size @ %%type_buffer_count @ - 
			\ addr num left(--
			2DUP > IF ( will not all fit)
				\ addr count amount_to_fit(--
				\ make sure we have a type buffer
				>R \ addr count (--
				OVER %%type_buffer> @  %%type_buffer_count @ + R@ MOVE \ put in as much as we can
				\ addr count(--
				SWAP R@ + SWAP R@ -   \ update send data to reflect what has been sent
				\ addr_new count_new(--
				R> %%type_buffer_count +!
				FALSE                  \ tell :write to send the packet
				                       \ and come back again
				EXIT
			THEN
			\ data will fit in the buffer
			DROP
			\ character we are up to since last record ( eol ).
			%%type_buffer> @  %%type_buffer_count @ + SWAP \ addr to count(--
			\ update %%type_buffer_count after you have done the address calculations
			DUP %%type_buffer_count +!
			MOVE
			TRUE
		;

		m: ( addr num--)
			DUP IF  \ There is some data
					BEGIN 
						_tcp_data>type_buffer IF \ return true if all ok
							EXIT
						THEN
						\ sent the data to the device to clear the buffer
						this :flush_file
					AGAIN
			ELSE 
				2DROP 
			THEN 
		; overrides :write

Returns true if data as the application consumes data %%tcp_rcv.used moves forward. If %%tcp_rcv.mext is greater than %%tcp_rcv.used then there is incoming data avialable. 

 
		m: ( --flag)
			%%tcp_state @ #tcps_abort =
			%%tcp_rcv.nxt @ %%tcp_rcv.used @ - 0> OR
		; overrides :key?

Urgent data only has a meaning if the tcp client type assigns it a meaning. The following methed is called in the proto task if the urgent bit is set.

The task does not see urgent data. It would seem the urgent data option has been so badly droken that it is not even used for interrupt process. It's obvious use. 

 
		m: ( pep --)
			DROP
		; method :urgent_data

Support functions for TCP

Tcp options

None of the RFC1323 options are handled. However this code must be able to scan across these options and ignore them.

If we return true the pep will go. Only set if the option list is badly structured 

 

		: _tcp_fault_option ( option -- byte_after flag)
			TRUE
		;

		: _tcp_unknown_option { ( option -- byte_after flag) }{
				zero 
				DUP CONSTANT _#code  1+
				DUP CONSTANT _#len   1+ 
				DUP CONSTANT _#opt_head DROP
			}
			DUP _#len + B@ 
			\ addr len(--
			DUP _#opt_head < IF
				\ option count doesn't even cover header
				\ we are dealing with rubbish
				+ TRUE 
				EXIT
			THEN
			+
			FALSE
		;

The option does nothing other than take up one byte position 

 
		: _tcp_align ( addr -- addr flag )
			1+ FALSE
		;


		: _tcp_mss { ( addr -- addr flag ) }{
				0 
				DUP CONSTANT _#code  1+
				DUP CONSTANT _#len   1+
				DUP CONSTANT _#data  2+ 
				DUP CONSTANT _#opt_length DROP
			}

			DUP _#len + B@ _#opt_length = IF
				\ option is well constructed
				DUP _#data + unalignedW@ 
				DUP %%tcp_snd.mss !
				\ set the type buffer size to the mss size
				%%type_buffer_size !
				_#opt_length + FALSE
				EXIT
			THEN
			\ it is not well structured.
			\ fail the packet
			DUP _#len + B@ + TRUE
		;

		CREATE _tcp_option_vectors 
			$04 tw,                   \ number of entries
			' _tcp_fault_option t,    \ 0 does not get processed here, just something to put in table
			' _tcp_align t,           \ 1 align
			' _tcp_mss t,			  \ maximum segment size.
			' _tcp_unknown_option t,  \ this and higher options are not supported

The option field is a byte. 

 
		: _tcp_process_an_option ( addr_opt -- addr_after flag )
			  DUP B@  _tcp_option_vectors vector
		;

Unknown options are simply ignored. 

 
		: _process_tcp_options { variable %pep -- ( flag ) }{
			variable %options_end
			}
			\ this is the common route , no options
			\ do as little as possible.
			%pep @ ep_protodata + @
			%pep @ ep_ipdata + @ -
			#tcp_header_end = IF
				FALSE
				EXIT
			THEN 

			\ if we get here we have options
			%pep @ ep_protodata + @ %options_end !
			%pep @ ep_ipdata + @ #tcp_header_end +
			\ option_pointer(--
			BEGIN
				\ end of option list code is a zero option
				DUP B@ not IF
					DROP
					FALSE	
					EXIT
				THEN
				\ list has finished
				DUP %options_end @  < not IF
					DROP
					FALSE
					EXIT
				THEN
				( opt_addr (-- new_option_addr FLAG )
				_tcp_process_an_option IF
					\ bad bad option
					DROP
					TRUE
					EXIT
				THEN
				DUP %options_end @ > IF
					\ if here structure of option list is rubbish
					DROP
					TRUE
					EXIT
				THEN
			AGAIN	
		;

In send window

We are talking about the outgoing packets seqence number here. In the beginning the send window is dependent on the ack and window received in incoming datagrams. 

			SEQ.NXT <= SEG.SEQ+SEG.LEN-1 
			and 
			SEG.SEQ <= RCV.END

This test will transmit one packet past the end of the window. It has one super dooper big advantage. The zero window code folds into the timeout code. I can't see why it won't work, but there must be some problem as all the implementations I have looked at pretend a zero window is some special thing. We will see. 

 
		:   _in_send_window { variable %pep ( -- flag ) }{ 
				variable %send_end }

			\ number of bytes unsent
			\ %%tcp_snd.end is only increased by packet steps.
			%%tcp_snd.end @ %%tcp_snd.nxt @ - 
			zero MAX
			%%tcp_snd.congestion.wnd @ MIN
			%%tcp_snd.nxt @ + %send_end !

			\ the end is not allowed to preceed %%tcp_snd.una
			\ but this is a null test as packets that meet this
			\ condition are no longer in the transmit list
			\ %pep @ ep_end_seq + @ %%tcp_snd.una @ - 0< IF
			\	DROP FALSE EXIT
			\ THEN
			\ 
			\ The start is not allowed to be past %send_end
			%pep @ ep_start_seq + @  %send_end @ - 0> IF
				FALSE
				EXIT
			THEN

			TRUE
		;

The tranmission task only schedules a timeout if there is data to be sent. Remember the task that takes packets from this list is on the same level as us. 

 
		: _schedule_timeout ( --)
			%%tcp_queue_sent queue_empty? not IF
				%%tcp_rexmt @ 
				\ The timeout is dependent on the timeout time 
				\ of the first packet in queue, if it has been sent.
				\ And the first item in the queue should have been sent.
				%%tcp_queue_sent get_list #queue_list_head + @ 
				ep_tcp_xclock + @  + 
				\ but we do not schedule a timeout on this tick, we have 
				\ to remember the round trip time can be less 1 tick.
				DUP xclock+ @ 2 + - 0< IF
					DROP
					xclock+ @ 2 +
				THEN
				tcp_transmit		
			THEN
		;
transmit

The transmit task doesn't get involved in packaging the data. TCP supports urgent data but the urgent data is part of the tcp sequence. Once you have commited the data to a particular seqence you have to stick with it, otherwise you add complications to the protocol. You have to start asking, can I alter the seqence now. You may be tempted to say, you know the other machine is up to you have a ack to tell you. The reply tells us where the machine was up to when it sent the reply. It could now be well past what we are going to resend. What set of data will the machine use. What we sequenced first or what we are about to resequence. Nope once the data is committed to a send, it's order must remain fixed.

So we have data that has been packaged by smarter routines than us, they have added the urgent data if required. There is a further anvantage in doing it this way. Routines that want speed can put there data into peps and use lower level routines to add the transmit packets onto this list. Thus avoiding a data movement.

If the other end has moved snd.una to a point partway through a packet ( whick is likely if the other end is having buffer problem, we do not modify the packet. It would take time as not only do we have to remove the unneeded data, we ould have to update the urgent pointer. Special conditions tests take time and introduce bugs, best not to do.

The flag field is used to set the tcp headers flag field. If the syn bit is set the option field is included.

flag is true if data sent.

This work out really really well. I like it.

A lot of things just happen.
Data exist in the list from snd.una to whatever has been queued by the task. If the task is waiting for queue space, the code that removes the data from the queue will wake the task when such an action happens. It's up to the When a packet timesouts and needs tranmission there can be many inflight. The first non ack doubles the timeout and retransmits the guilty packet. The window congestion window is also reduced. However if the limit is the amount of data available for transmission, this has little effect. More time has to pass before other packets are trasmitted. 

 

	: _clone_datagram { variable %pep (  -- pep2) }{
			variable %buffer
			}
		%pep @  ep_len + @ 
		\ length(--
		['] get_free_buffer CATCH IF
			\ we can simple pretend it didn't happen
			\ and things will sort themseleves out
			DROP
			zero
			EXIT
		THEN
			
		%buffer !
		\ copy data into transmit pep
		\ (--
		%pep @ %buffer @ %pep @ ep_len + @ MOVE
			
		\ update ep_ipdata
		%pep @ ep_ipdata + @ %pep @ -
		%buffer @ + %buffer @ ep_ipdata + !

		\ update protodata
		%pep @ ep_protodata + @ %pep @ -
		%buffer @ + %buffer @ ep_protodata + !	
		%buffer @	
	;

		: _tcp_send_pep_contents { variable %pep }{

			variable %buffer

			}

			%pep @ _clone_datagram %buffer !
													
			\ updates the ack and window. Note we don't alter the packet. 
			\ The flags are set when the packet is queued. This means we
			\ send the syn without data. But so what
			\ we are trying to write a TCP driver that
			\ interoperates not push the standard to it's limit.

			%buffer @ ep_ipdata + @
			%%tcp_rcv.nxt @ OVER #tcp_ack + !
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - SWAP #tcp_window + W!

			%buffer @ queue_ip
		;

		: _tcp_send_contents { variable %pep -- }
			\ see comments below
			xclock+ @ %pep @ ep_tcp_xclock + !
			%%tcp_snd.end @ %%tcp_snd.una @ - 0> not IF
				\ we are sending into a zero window.
				\ If an ack is required, send only ack, as you
				\ cannot piggy back data in this situation and be assured the
				\ ack will get accepted. A real protocol suff up I think; but that is
				\ the way it is. The problem is the rules on page 26 of RFC793.
				\ If no ack is required send the data. It is nothing more than a probe
				\ and it may as well be a probe that can move things forward,
				\ things can change while the packet is inflight.
				\
				\ Remember the window open can be lost
				\ so you have to probe every now and again.
				\ The probe can be the next valid packet. The other end
				\ will just drop it if window is still zero. As there is no
				\ data to be acked, who cares.

				\ I should add that this test brings little to the table. If data
				\ is coming in the other direction most of the acks will be acks.
				\ This probe, if it always contained data would be nothing more than
				\ a lost ack occuring every now and again.

				\ This is a valid state, we should not increment
				\ ep_tcp_tries. However if we do this we can end up with TCP 
				\ connections left open forever. It would occure as follows.
				\ 1) Remote machines closes window.
				\ 2) Remote machine dies.
				\ But that is just the way it is.
				%%tcp_send_ack @ IF
					EXIT
				THEN
			ELSE
				1 %pep @ ep_tcp_tries + +!
			THEN
			FALSE %%tcp_send_ack !
			%pep @ _tcp_send_pep_contents	
		;

Trace down the sent queue and send timed out packets the trace down has finished when we arrive at untimed out packet. We have a small problem, we can't simple take the packet out of the list and send, we have to clone it. We can not get away from this. TCP requires one data copy. The IP stack as written is based on two principles. 1) we don't care how the packet was generated and 2) if the code cannot deal with the packet it can destoy it. We are only allowed to destoy transmit data if the other end has acked it. 

 
		CREATE _$timeout ," To many transmit retries"
		: _try_and_send_data ( -- )
			%%tcp_queue_sent queue_empty? not IF
				%%tcp_queue_sent get_list #queue_list_head +
				BEGIN
					\ if the entry is zero we don't test time
					\ and we finish the loop
					@ DUP DUP IF
						ep_tcp_xclock + @ xclock- @ + 
						%%tcp_rexmt @ + 0< 
					THEN
				WHILE
					\ list (--
					\ if the number of reties is too great we abort the connection
					DUP ep_tcp_tries + @ #abort_retries > IF
						DROP
						\ allow other code to set abort reson in this case
						\ The abort reson may come from ICMP messages
						%%tcp_abort_reason @ ?DUP not IF
							_$timeout
						THEN
						this :abort_connection
						EXIT
					THEN
					\ pep(--
					\ remember the congestion window reduction can take what was in
					\ the send window out of the window. We should take note of this. 
					\ If this occures data should be sent as the congestion 
					\ can never be reduced below one packet.
					DUP _in_send_window not IF
						\ there is no need to look at the unsent queue it will definitly be
						\ outside the window.
						DROP
						EXIT
					THEN
					\ is the packet still in the window. Remember every packet retransmitted 
					\ reduces the congestion window. 

					\ pep(--
					DUP _tcp_send_contents
					\ The standard requires us to reduce the congestion window by
					\ half.
					\ 
					\ list(--
					%%tcp_snd.congestion.wnd @
					1 RSHIFT
					\ don't reduce below the maximum segment.
					%%tcp_snd.mss @ MAX
					%%tcp_snd.congestion.wnd !				
					
					\ and double the retransmit time
					%%tcp_rexmt @ 1 LSHIFT 
					\ the is a maximum timeout
					#max_timeout MIN
					%%tcp_rexmt !
				REPEAT
				DROP
			THEN
			\ now we have to deal with unsent data
			BEGIN
				%%tcp_queue_unsent queue_empty? not
			WHILE
				%%tcp_queue_unsent get_list #queue_list_head + @ 
				DUP _in_send_window not IF
					DROP
					EXIT
				THEN
				\ we have to try and queue the data on the sent queue
				\ if we fail it has to remain on the unsent.
				\ Too much data is inflight
				\ pep(--
				%%tcp_queue_sent zero enqueue_try IF
					\ couldn't queue on the sent queue
					\ too many packets inflight.
					EXIT
				THEN
				\ (--
				%%tcp_queue_unsent dequeue
				\ pep(--
				DUP _tcp_send_contents
				ep_end_seq + @ 1+ %%tcp_snd.nxt !
			REPEAT
		;

Look to see if ack can be piggy backed on data. If not send empty ack packet. 

 
		: _send_data ( --)
			\ if we sent something the ack is in the head
			_try_and_send_data 
			%%tcp_send_ack @ IF
				FALSE %%tcp_send_ack !
				_send_an_ack			
			THEN
			_schedule_timeout
		;

This is only called if datagram is only transmitted once. 

 
		: _update_round_trip  { ( time -- ) }{
			\ values taken from comer volume 1 edition 3
			3 CONSTANT #rtt_gain_asr
			2 CONSTANT #rtt_dev_asr
			3 CONSTANT #dev_gain
			}
			\ the round trip time is done in 10 msec inc, it can be zero
			\ if less than 10 msec, just round up by 1. 
			1+
			DUP %%tcp_rtt @  -
			\ time diff(-- 
			DUP #rtt_gain_asr >>a
			%%tcp_rtt @ + %%tcp_rtt_smooth !
			\ time diff(--
			SWAP %%tcp_rtt !
			\ diff(--
			ABS %%tcp_rtt_dev @ - 
			#rtt_dev_asr >>a 
			%%tcp_rtt_dev @ + 
			%%tcp_rtt_dev !
			%%tcp_rtt_smooth @ %%tcp_rtt_dev @ #dev_gain * + 
			%%tcp_rexmt !
		;

Incoming data, link it into receive list. 

 
		: _link_tcp_pep { ( head) variable %pep -- ( flag ) }{	
				variable %in_rcv.nxt 
				variable %fin_flag }
			\ only send an ack if this moves forward.
			\ if it doesn't packet is out of order and ack will be wasted.
			\ fast recovery requires an ack every time a packet is received
			\ out of order. We don't support it.
			%%tcp_rcv.nxt @ %in_rcv.nxt !
			FALSE %fin_flag !

			\ link(--
			\ to be linked after this	
			%pep @ SWAP link_double	
			
			\ we don't include the seq and fin flag in the queue room calculations.
			\ queue room is only used to protect us from attack
			%pep @ ep_protocount + @ NEGATE 
			_lock_word
			%%receive_list_room +!
			_unlock_word
			\ If here the incoming moves the sequence forward. It may however
			\ have been the key packet and we can now move forward multiple packets
			\ (--
			%%receive_list @
			BEGIN
				?DUP 
			WHILE
				\ if the beginning of the segment is less or equal to  rcv.nxt
				\ then the end can become rcv.nxt
				DUP ep_start_seq + @  
				%%tcp_rcv.nxt @ 
				- 0> not IF
					DUP ep_end_seq + @ 1+ 
					%%tcp_rcv.nxt @ MAX
					%%tcp_rcv.nxt !
					%%tcp_rcv.nxt @ %in_rcv.nxt @ <> IF
						TRUE %%tcp_send_ack !
						xclock+ @ #tcp_ack_delay + tcp_transmit
						\ the receiving task now needs to transfer data
						\ to it's buffers as required.
						_wake_receiving_task
					THEN
				ELSE
					\ well that is the end of this trick there is a hole
					DROP 
					_update_rcv_window
					%fin_flag @
					EXIT
				THEN
				\ as we have moved the received window forward we have to look 
				\ at the fin flag.
				\ the packet that is now the last consumed may be the one we want.
				DUP ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
					TRUE %fin_flag !
				THEN
				\ move onto next entry in list
				@
			REPEAT
			_update_rcv_window
			%fin_flag @
		;

Packet sequence is checked before entering this it is acceptable if in is greater or equal to %tcp_rcv.nxt and within our window range. We only check that the packet seqence is in the window range this means that the amount of data present can be greater than the receive window. But so what. This code will ever queue the packet on the recieve_list or get rid of it.

Flag is true if fin processed. If the incoming packet contains a fin the data may not be finished. Remember packets can come out of order rcv.next has to have move up to the packet.

This code is responsible for initiating the ack. The ack is initated by setting %%tcp_send_ack and consuming the packet.

Because we are responsible for sending the ack we have to sort the packets into order.

We are allowed to queue packets past %%tcp_rcv.end. We are not allowed to ack them.

Duplicate packets will be queued. They will be returned when the data is read. 

 
		: _queue_tcp_pep { variable %pep -- ( fin_flag ) }{
				variable %incoming_seq
			}

			\ set incoming start
			%pep @ ep_start_seq + @ %incoming_seq !
			\ ok we have to add to data structure
			\ if the %incoming end is not greater than rcv.next then it is a duplicate packet.
			\ Deplicate packets are rejected by the sequence check done very early in
			\ the piece.
			%%receive_list BEGIN
				DUP @
			WHILE
				\ if the seq of the next packet in the list is greater then the
				\ sequence of this then this is the link spot
				DUP @ ep_start_seq + @ 
				\ compare the next sequence  ( the ends) 
				%incoming_seq @ - 0< not IF
					\ link(--
					%pep @ _link_tcp_pep
					\ fin_flag(--
					EXIT
				THEN
				@
			REPEAT
			\ link(--
			\ if we get here we have reached end of this
			\ link the packet in at the end
			%pep @ _link_tcp_pep
		;


		: _next_seq_in_packet? ( pep  -- flag )
			DUP ep_start_seq + @ 
			\ pep start(--
			SWAP ep_end_seq + @ 
			\ start end(--
			\ the end is not allowed to preceed %%tcp_rcv.nxt
			%%tcp_rcv.nxt @ - 0< IF
				FALSE EXIT
			THEN
			\ the start is not allowed to be after %%tcp_rcv.nxt
			\ start(--
			%%tcp_rcv.nxt @ SWAP - 0< IF
				FALSE EXIT
			THEN
			TRUE
		;

If the packet contains no data and no fin flag it is irrelevent to this code. We only acks stuff we have been sent. Or in other words you do not ack an ack. The SYN is dealt with as a seperate issue. 

 
		: _receive_tcp_pep { variable %pep -- ( fin_flag ) }
			%pep @ ep_protocount + @ zero = 
			%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND not 
			AND IF
				%pep @ kill_free_buffer
				\ definitly no fin flag.
				FALSE
				EXIT
			THEN
			
			\ this is our urgent data support. Note that if we receive the urgent
			\ data twice then :urgent_data will get executed twice. 
			\ Note that urgent data will not appear in the normal data stream
			%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_urg AND  IF
					%pep @ this :urgent_data
			THEN
 
			\ there are two reasons to use this packet
			\ 1) We have room in the list
			\ 2) The next byte to receive is in the packet
			\ We have to have the last as the list may list may be filled with
			\ crap we do not need
			\ we take them from most likely to least this is in the critical path

			\ note we are not real fussy about the receving buffer size.
			\ It is really a ling list whats a packet between friends.
			%%receive_list_room @ 0> IF
				%pep @ _queue_tcp_pep
				EXIT
			THEN
			%pep @ _next_seq_in_packet? IF
				%pep @ _queue_tcp_pep
				EXIT
			THEN
			\ If we get to here we can't deal will packet
			\ Because of the way we receive packets it can be our
			\ fault ( but not likely). Duplicate packets take up
			\ queue room. The room is recovered when the applicatin dequeues.
			\ This is why we unconditionaly accept the next pascket in seqence.
			\ The queue can be filled with rubbish.
			%pep @ kill_free_buffer
		;

The %%tcp_queue contains unacked packets. Before this code is called one must check that the ack is acceptable, this deals with wild packets. We can then assume we are dealing with rational data. Trace down the queue and remove packets whose end comes before the new ack value. Remember the ack value is what is expected next. The queue is in seqence number order. If a test fails the job is done.

The ack can ack multiple packets. The RTT is a measure of how long it takes to get a packet acked. Not how long it takes the packet to get to the computer, and the ack to get back. Unfortunatly we have this thing called "ack delay". On short hops this is the most critical issue. This stack delays by #tcp_ack_delay as an example. We therefor need to use the send time of the first packet in the group acked. 

 
		: _tcp_acked { variable %pep -- }{
				variable %update_trip
			}

			\ remember ack is next seq expected
			FALSE %update_trip !

			\ move the window forward. Remember there can be multiple acks 
			\ with the same seqence number and we can receive them out of order.
			\ Only update if this ack moves things forward.
			%pep @ ep_ipdata + @ #tcp_ack + @ DUP 
			%%tcp_snd.una @ 
			- 0> IF
				%%tcp_snd.una !
			ELSE
				\ and if it doesn't move things forward then we are finished
				\ with this
				DROP
				EXIT
			THEN

			%%tcp_snd.una @ %pep @ ep_ipdata + @ #tcp_window + W@ + 
			DUP %%tcp_snd.end @ - 0> IF
				%%tcp_snd.end !
			ELSE 
				DROP
			THEN
			\ just because ack looked correct we should not asussume
			\ we have data in list, anything is possible.
			\ (--
			\ remove those packets that have now been acked.			 
			\ the queue has only one list.
			%%tcp_queue_sent get_list #queue_list_head +
			BEGIN
				%%tcp_queue_sent queue_empty? IF
					DROP
					EXIT
				THEN
				\ head (--
				DUP @ 
				ep_end_seq + @
				\ list last_seq(-- 
				%%tcp_snd.una @ - 0< 
			WHILE
				\ head (--
				%%tcp_queue_sent dequeue
				\ head packet(-- 
				DUP ep_tcp_tries + @ 1 = IF
					\ packet has only been sent once 
					\ this is an unambiguous ack.
					%update_trip @ not IF 
						TRUE %update_trip !
						DUP ep_tcp_xclock +  @ NEGATE xclock+ @ +
						\ head packet round_trip_time(--
						 _update_round_trip
					THEN
				THEN
				kill_free_buffer
			REPEAT
			DROP
		;

snd.una <= seg.ack <= snd.nxt The ack is the next byte expected. or in words the ack can be equal to the last ack and can be equal or less than the last byte sent. Remeber the ack gives the next byre to be received. 

 
		: _ack_acceptable? ( pep -- flag ) 
			ep_ipdata + @ #tcp_ack + @ DUP %%tcp_snd.una @ - 0< IF
				DROP FALSE EXIT
			THEN
			%%tcp_snd.nxt @ - 0> IF
				FALSE EXIT
			THEN
			TRUE
		;

We process the ack even if the ack value equals %%tcp_snd.una as the ack may contain a window update, and _tcp_acked looks after the window.

On error: (SEG.ACK < SND.UNA), it can be ignored. If the ACK acks something not yet sent (SEG.ACK > SND.NXT) then send an ACK, drop the segment, and return. 

 
		: _process_ack { variable %pep -- }
			%pep @ _ack_acceptable? IF
			    \ (--
				\ we get here all is ok
				\ remove packets that have been acked.
				%pep @ _tcp_acked
			ELSE
				%pep @ ep_ipdata + @ #tcp_ack + @  
				%%tcp_snd.nxt @ - 0> IF
				    \ ack is for data not sent.
					TRUE %%tcp_send_ack !
				THEN
			THEN
		;

			 
			RCV.WND = 0 SEQ.SEQ = RCV.NXT
			or
			RCV.NXT =< SEQ.SEQ < RCV.END 
			or 
			RCV.NXT =< SEG.SEQ+SEG.LEN-1 < RCV.END

The last two reduce to: 

			RCV.NXT <= SEG.SEQ + ( SEG.LEN-1 ZERO MAX)
			and 
			SEG.SEQ < RCV.END

If I allow the reception of data up to RCV.END I will accept one packet after the window has been set to zero. Big deal, I just have to make sure I don't ack past RCV.END that is likely to send some stacks to the moon. It will also mean no special handling has to occure for a zero window. If all stacks where written like this the zero window probe and the ack contained therein could be in the next packet to be sent. If I use a sandard packet for the zero probe then the probe ack will not be accepted by a stack written to the standard. As the zero window probe does not occure often it would not be a big problem. I am tempted.

There is the question of urgent data. I think there should be a clear boundry between the protocol and the applicaiton. Once you commit to a sequence thats is it your committted. This stack is written that way.

This sysem will discard a packet if the sequence numbers are within a range already received. It will not check for a difference. And if there is a difference pray tell which is right. The answer definitly isn't " the last one received".

Anyway, allow one byte past the end and the test reduces to: 

			RCV.NXT <= SEG.SEQ + ( SEG.LEN-1 ZERO MAX ) 
			and 
			SEG.SEQ <= RCV.END

This is called in all states that can receive data. This routine sets the fields ep_start_seq and ep_end_seq. these can then be used to deccide what to do with hte packet. 

 

		: _seq_acceptable? { variable  %pep  -- ( flag ) }{ 
				variable %incoming_start 
				variable %incoming_end }
			%pep @ ep_ipdata + @ #tcp_seq + @ DUP %incoming_start !
			DUP %pep @ ep_start_seq + !
			
			%pep @ _end_sequence 
			
			\ start end(--
			\ If no data the end is before, for this test that is
			\ not what we want 
			2DUP - 0> IF
				DROP
			ELSE
				NIP
			THEN
			%incoming_end !
			\ (--
			\ the end is not allowed to preceed %%tcp_rcv.nxt
			%incoming_end @ %%tcp_rcv.nxt @ - 0< IF
				FALSE EXIT
			THEN
			\ the start has to proceed or be equal to %%tcp_rcv.end 
			\ using the start allows us to receive past the window
			\ as we only test that the first byte in the packet is within.
			\ the window. See discussion above. This is not in accordance with
			\ standard.
			%%tcp_rcv.end @ %incoming_start @ - 0<  IF
				FALSE EXIT
			THEN
			TRUE
		;

If flag is true we have disposed of packet. If false the packet is. This can only be used if we have other ends sunc value. Because all packets have to past this test we have to set seq to snd.end after we have sent our fin and it is acknowledged. So when we have finished sending data and the fact has been acked by other end, the acks for packets received form other end will have a seg one past the fin flag seqence, and the fin flag will not be set.

Even though we have the other ends syn value we do not use this test in syn received. In that state it is posible to have an outstanding syn ack packet that could move us to established. This packet would not be accepted if we used this test. 

 
		: _packet_out_of_window { variable  %pep -- ( flag ) }
			%pep @ _seq_acceptable? not IF
				\ if not check reset
				%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_rst AND IF
					%pep @ kill_free_buffer
					TRUE
					EXIT
				THEN
				\ else send an ack
				%pep @ kill_free_buffer
				TRUE %%tcp_send_ack !
				TRUE
				EXIT
			THEN
			FALSE 
		;

The state code

The in are executed withn the proto task, the outs are executed within the transmit task

Open in both directions. This has to come before the syn states because it can be called from these states. 

 
		CREATE _$syn/rst1 ," Syn or Rst packet received in established state"
		: _in_tcps_established { variable %pep -- }
			%pep @ _packet_out_of_window IF 
				EXIT 
			THEN
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				%pep @ kill_free_buffer
				_$syn/rst1 this :abort_connection
				EXIT
			THEN
			\ flags(--
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ this will schedule a transmit if more 
			\ data in the tranmit queue can be sent.
			%pep @ _process_ack
			\ flag is true if fin received and used
			\ This will schedule an ack if new data is received.
			%pep @ _receive_tcp_pep IF 
				\ true if fin processed, _receive_tcp_pep will
				\ have woken the receiving task ( if it is receiving,
				\ so the news can be delivered.
				#tcps_closewait %%tcp_state !
				\ close the window, there is no more data 
				%%tcp_rcv.nxt @ %%tcp_rcv.end !
			THEN
		;


		: _out_tcps_established ( --)
			_send_data
		;

The diagram does describe the implementation. The diagram does not describe RFC793. How a < syn> is treated when in the "< syn> received" state differs slightly. Doing it like this brings two advantages. The < syn> handshake recovers from lost packets faster. The code is cleaner. According to Stevens Volume 1, BSD stuffed up this state ( he didn't say which stack version), so noone has any excuse to complain if I handle it a little differently but correctly.

It is my considered opinion that there is nothing nasty about a nasty_gram. But they are of limited use. In theory a transaction could occur in 4 packets. 

			client->server      syn
			server->client      ack syn data fin
			client->server      ack data fin
			server->client      ack

For this case to be possible the server has to get its act together before the ack of the syn is sent. In the listen state we do not delay the ack. So it just isn't going to happen. Further it is not wise to commit resources on a syn as the syn could lie about who sent it. It is best to wait until the client returns. The client still could make life hard for you, but at least you know who it is.

The minimum transaction should be. 

			client->server      syn
			server->client      ack syn
			\ this can happen as data can be queued and close called defore 
			\ inital round
			client->server      ack data fin
			\ possible
			server->client      ack data fin
			client->server      ack

Enough of the idle chat lets get back into it. 

 
		CREATE _$rst1 ," reset received in syn sent state"
		: _in_tcps_syn_sent { variable %pep -- }
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP 
			#tcpf_ack AND 0<>
			%pep @ _ack_acceptable? AND IF
				\ flags(--[acks]
				DUP #tcpf_rst AND IF
					DROP
					\ [acks] [reset]
					%pep @ kill_free_buffer 
					_$rst1 this :abort_connection
					EXIT
				THEN
				#tcpf_syn AND IF
					\ (--
					\ [acks] [syn]

					\ Set link to priority selected
					%pep @ [ ep_data ip_tos + ]T LITERAL + B@ %%priority !
					\ set the %%local_machine, it is dependent on the 
					\ address received in the syn datagram, not the
					\ interface the reply is sent.
					%pep @ [ ep_data ip_dst + ]T LITERAL + @ %%local_machine !

					\ may set the maximum transmit segment size
					%pep @ _process_tcp_options IF 
						\ bad bad structure
						%pep @ kill_free_buffer
						EXIT
					THEN
					\ set the values that need to be set from syn segment
					%pep @ ep_ipdata + @ #tcp_seq + @
					\ seq(--
					\ allow for the SYN
					DUP %%tcp_rcv.iss !
					DUP %%tcp_rcv.used !

					1+ 
					DUP %%tcp_rcv.nxt !
					#rcv_data_buffer + %%tcp_rcv.end ! 
					

					\ remove the syn info from packet so it can 
					\ then treated as just another packet
					1 %pep @ ep_ipdata + @ #tcp_seq + +!
					
					%pep @ ep_ipdata + @ #tcp_flags + B@ 
					[ #tcpf_syn -1 XOR ]T LITERAL AND 
					%pep @ ep_ipdata + @ #tcp_flags + B!

					\ set the ack flag as the syn has to be acked even if no more data
					TRUE %%tcp_send_ack !
					
					#tcps_established %%tcp_state !
					%pep @ _in_tcps_established
					EXIT
				THEN
				\ (--
				\ [acks] [other]
				\ it is possible for the other end to send 
				\ a ack without a syn. It's a complete waste of time
				\ just drop and wait for something sensible.
				\ Because we refuse to update the snd.una we
				\ can use _ack_acceptable? as our test for entry 
				\ into this code.
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ other end did not ack our start of conversion
			\ is it trying to start one
			\ flags(--
			DUP [ #tcpf_syn #tcpf_ack OR ]T LITERAL AND #tcpf_syn = IF
				DROP
				\ [syn] [noack]

				%pep @ [ ep_data ip_tos + ]T LITERAL + B@ %%priority !

				\ set the %%local_machine, it is dependent on the 
				\ address recevied int he syn datagram, not the
				\ interface the reply is sent.
				%pep @ [ ep_data ip_dst + ]T LITERAL + @ %%local_machine !

				%pep @ _process_tcp_options IF
					%pep @ kill_free_buffer
					EXIT
				THEN
				%pep @ ep_ipdata + @ #tcp_seq + @

				\ 
				DUP %%tcp_rcv.iss !
				DUP %%tcp_rcv.used !
				1+ 
				DUP %%tcp_rcv.nxt ! 
				#rcv_data_buffer + %%tcp_rcv.end ! 
				
				\ change state to syn received
				#tcps_synrcvd %%tcp_state !

				\ need to ack the received syn				
				TRUE %%tcp_send_ack !
				EXIT
			THEN
			\ flag(--
			\ [other]
			\ other  end is speaking complete rubbish, knock it on the head.
			#tcpf_rst AND not IF
				%pep @ _send_tcp_reset
			THEN
			%pep @ kill_free_buffer
		;

There is nothing to ack because of the state we are in %%tcp_rcv.nxt and %%tcp_rcv.end will not be set to correct values as we do not have the start seq. They are however set in the construct method to default values. We do not reset the %%tcp_send_ack flag because we don't send an ack 

 
		: _out_tcps_syn_send ( --)
			%%tcp_snd.is @ 
			\ default values are set in construct
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_syn _send_empty_segment
			\ schedule a retranmit
			%%tcp_rexmt @ xclock+ @ + tcp_transmit
		;

You come through this state for an active open. To avoid SYN attacks the passive open keeps track of syn received in the LISTEN State, moving to established when a reply to the syn we sent out comes back. In other words the diagram on page 23 RFC 793 is not followed. The line from LISTEN to this state does not exist.

The words on page 69 invalidate a valid open seqenece. It look like this. 

				side a                         side b
				------------------------------------------------------
			(1)                                  syn[200] ( in syn sent)
			(2) syn[100] -->                     receive(2)
			(3)                              (-- syn[200] ack[101]  ( b in syn received)
			(4) receive(1) ack[201]syn[100] -->  receive(4)         ( a in syn received)

The forth step is valid. It would be rejected because seg.seq is less than receive next. What happens if we follow standard. An ack must be sent. 

			(5)                              (-- ack[101] seq [201] ( error responce)
			(6) Receive (5)                                         ( a is in established) 
			(7)                              (-- syn[200] ack [101] ( b times out )
			(8) Receive (7) seq [101] ack [201] -->                 ( error responce)
			(6) seq [101] data  ack [201] -->    receive(6)         ( b is now in establish)

What happens if you accept it and correctly form packet. 

			(5)                              (-- ack[101] seq [201] ( b in established)
			(6) Receive (5)                                         ( a is established)

I think this surves to highlight just how robust this whole thing is. It required the timeout of b) to move b) to the established state. a) sending data would have also done it. 

			There are three possibilities here
			Other end saw our original syn and is in this state. 
					 --> sends a ack and syn
			Other end missed everthing                               
					--> sends syn 
			Saw our syn with ack sent from this state     
					--> sends an ack

If the syn bit is set it is a reply to my original syn, or a syn becaue the other end has seen nothing. Either case can be happily handled by _in_tcps_syn_sen. 

 
		: _in_tcps_syn_receive { variable %pep -- }
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			#tcpf_syn AND IF
				\ datagram is replying to early packet
				\ go back a state
				DROP
				#tcps_synsend %%tcp_state !
				%pep @ _in_tcps_syn_sent
				EXIT
			THEN
			DUP #tcpf_ack AND 0<> 
			%pep @ _ack_acceptable? AND IF
				DROP
				\ our syn has been acked. We can move to the established state
				\ with this packet.
				#tcps_established %%tcp_state !
				%pep @ _in_tcps_established
				EXIT
			THEN
			\ Other  end is speaking rubbish.
			\ In this state we just ack with what we believe is the correct 
			\ situation. Unless it is a reset ,in which case we just ignore it.
			#tcpf_rst AND not IF
				TRUE %%tcp_send_ack			
			THEN
			%pep @ kill_free_buffer
		;

We have received a syn. We now sent appropiate responce. The responce will be resent if nothing comes back 

 
		: _out_tcps_syn_receive ( --)
			FALSE %%tcp_send_ack !
			%%tcp_snd.is @ 
			\ default values are set in construct
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_syn #tcpf_ack OR _send_empty_segment
			\ schedule a retranmit
			%%tcp_rexmt @ xclock+ @ + tcp_transmit		
		;

In this state we are trying to close the link we have sent the seqment with the fin. we are receiving data, if SND.UNA equals SND.NXT then we move to fin-wait2. Data received from other end should be treated as normal, but as we enter this state because we are closing data received from other end is dumped. 

 
		CREATE _$syn/rst2 ," syn or reset in finwait1 state"
		: _in_tcps_finwait1 { variable %pep ( --) }
			%pep @ _packet_out_of_window IF EXIT THEN

			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				%pep @ kill_free_buffer
				_$syn/rst2 this :abort_connection
				EXIT
			THEN
			DUP #tcpf_ack AND not IF
				DROP
				%pep @ kill_free_buffer 
				EXIT
			THEN
			%pep @ _process_ack
			\ This will schedule an ack if new data is received.
			\ kill received packets until the magic last received.
			#tcpf_fin AND IF \ remote fin received 
				%pep @ _ack_last_fin
				%%tcp_snd.una @ %%tcp_snd.nxt @ = IF
					\ we have received fin
					\ other end has acked our packet
					#tcps_timewait %%tcp_state !
					_wake_receiving_task
				ELSE 
					\ still waiting for ack from other end
					#tcps_closing  %%tcp_state !
				THEN 
			ELSE
				\ not a fin received
				%%tcp_snd.una @ %%tcp_snd.nxt @ = IF
					#tcps_finwait2 %%tcp_state !
				THEN
			THEN
			%pep @ kill_free_buffer
		;

This this gets called we have sent our fin we are waiting for a reply. The packet with the fin set is in the send data queue. There can still be heaps of packets unacked. 

 
		: _out_tcps_finwait1 (  --)
			_send_data
		;

Our fin is acked, we are still receiving from other end the other end no longer has to ack as we are not sendng; we do not process the ack. We have to ack data received. We do this through the transmit task as that is how we get the delayed ack.

As I read RFC 793, it says to drop the segment if the ack bit is off. But in this state the other end is not acking our data so it is a stupid requirment for this state

In theory the other end can continue to send us data. As we entered fin-wait1 because we wanted to close the link, theory has no relevence to practice.

We dump all received data until a fin arrives then we close. 

 
		CREATE _$syn/rst3 ," Syn or Rst in finwait2 state"
		: _in_tcps_finwait2 { variable %pep ( --) }
			%pep @ _packet_out_of_window IF EXIT THEN
			\ 
			%pep @ ep_ipdata + @ #tcp_flags + B@ [ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				%pep @ kill_free_buffer
				_$syn/rst3 this :abort_connection
				EXIT
			THEN
			\ kill received packets until the magic last received.
			%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin 
			AND IF \ remote fin received 
				%pep @ _ack_last_fin
				\ we have received fin
				\ other end has acked our fin
				\ ack remote fin and enter time wait
				#tcps_timewait %%tcp_state !
				_wake_receiving_task
			THEN
			%pep @ kill_free_buffer
		;

We do not schedule a timeout as we have sent all data, we simple have to send an ack. 

 
		: _out_tcps_finwait2 ( pep --)
			FALSE %%tcp_send_ack !
			_send_an_ack	
		;

Other end has closed we are still sending data. A close will move us out of this state. As far as we are concerned things are established and we are going for it.

In reality the other end has probably closed and has no interest in what we have to say. 

 

		CREATE _$syn/rst4 ," Syn or Rst in closewait state"
		: _in_tcps_closewait  { variable %pep -- }
			%pep @ _packet_out_of_window IF EXIT THEN

			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP 
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				%pep @ kill_free_buffer
				_$syn/rst4 this :abort_connection
				EXIT
			THEN
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer 
				EXIT
			THEN
			%pep @ _process_ack
			\ there should be no new data
			\ from remote as it has sent a fin
			%pep @ kill_free_buffer
		;

		: _out_tcps_closewait ( --)
			_send_data
		;

Remote started close we have seen there fin we have sent our fin and waiting for ack of it we no longer have to send acks but retransmission may be required. Retransmission is the problem of the tranmit tasks. Ther remote should now be in close_wait 

 
		CREATE _$syn/rst5 ," Syn or Rst in lastack state"
		: _in_tcps_lastack { variable %pep -- }
			%pep @ _packet_out_of_window IF EXIT THEN

			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				%pep @ kill_free_buffer
				_$syn/rst5 this :abort_connection
				EXIT
			THEN
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer 
				EXIT
			THEN
			%pep @ _process_ack
			%pep @ kill_free_buffer
			\ ack of our fin will move us on
			%%tcp_snd.una @ %%tcp_snd.nxt @ 
			
			= IF
				#tcps_closed %%tcp_state !
				_wake_receiving_task			
			THEN
		;

		: _out_tcps_lastack ( --)
			_send_data
		;

Remote sent fin; we are still waiting for an ack of ours. We will not ack incoming packets under any circumstances. 

 
		CREATE _$syn/rst6 ," Syn or Rst in closing state"
		: _in_tcps_closing { variable  %pep -- }
			%pep @ _packet_out_of_window IF EXIT THEN
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				%pep @ kill_free_buffer 
				_$syn/rst6 this :abort_connection
				EXIT
			THEN
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer 
				EXIT
			THEN			
			%pep @ _process_ack
			%pep @ kill_free_buffer
			\ ack of our fin will move us on
			%%tcp_snd.una @ %%tcp_snd.nxt @ = IF
				#tcps_closewait %%tcp_state !
				_wake_receiving_task			
			THEN
		;

To get into this state we still waiting for an ack up to our fin. We restransmit unacked packets until the ack comes. To get to this point the fin must be in the retransmission window. And the packet containing the fin must have been sent once. 

 
		: _out_tcps_closing ( --)
			_send_data
		;

If this occues we have entered the timewait state and the object has not been destroyed by the task We do not have to worry about restarting the timewait timer as it has not been set yet. Don't give the ack problem to the transmit task, it is unlikely the object will remain to have the problem dealt with. 

 
		: _in_tcps_timewait ( pep --)
			kill_free_buffer
			_send_an_ack
		;

Nothing to do object will go soon. Somehow the object got scheduled for transmission in this state. The timeout occured before the object was destoyed and timewait issue transfered to the demux table. Not a big deal something that happens when closing down things that are dealt with by multiple threads. 

 
		: _out_tcps_timewait ( --)
		;

We are closing down the link but we received something before all was cool. Both ends have finished talking. 

 
		: _in_tcps_close ( pep --)
			DUP _send_tcp_reset
			kill_free_buffer
		;

		: _out_tcps_close ( --)
			\ nothing to do
		;

These should never get executed. 

 
		: _in_tcps_error ( pep --)
			kill_free_buffer
			1 %%tcp_state_error +!
		;

		: _out_tcps_error
			1 %%tcp_state_error !
		;


		CREATE _in_tcp_state_table
			' _in_tcps_close t,
			' _in_tcps_close t,
			\ everridden by the listen vector in the server code
			' _in_tcps_close t,
			' _in_tcps_syn_sent t,
			' _in_tcps_syn_receive t,
			' _in_tcps_established t,
			' _in_tcps_finwait1 t,
			' _in_tcps_finwait2 t,
			' _in_tcps_closewait t,
			' _in_tcps_lastack t,
			' _in_tcps_closing t,
			' _in_tcps_timewait t,
			' _in_tcps_error t,

		CREATE _out_tcp_state_table
			' _out_tcps_close t,       \ 0
			' _out_tcps_close t,       \ 4
			\ overriden by the listen vector in the server code
			' _out_tcps_close t,       \ 8
			' _out_tcps_syn_send t,    \ 0C
			' _out_tcps_syn_receive t, \ 10
			' _out_tcps_established t, \ 14
			' _out_tcps_finwait1 t,
			' _out_tcps_finwait2 t,
			' _out_tcps_closewait t,
			' _out_tcps_lastack t,
			' _out_tcps_closing t,
			' _out_tcps_timewait t,
			' _out_tcps_error t,

The tcp checksum has been checked What we do with the packet depends on the current state. 

 
		m: { variable %pep -- }
			\ make sure packet belongs to tcp protocol, if a ICMP message
			\ at this stage it is simple returned to the free buffer pool
			\ more should be done
			%pep @ [ ep_data ip_proto + ]T LITERAL + B@ IPT_TCP <> IF
				%pep @ kill_free_buffer
				EXIT
			THEN
			%pep @ _in_tcp_state_table %%tcp_state @ #tcps_error MIN + @execute
			%%tcp_send_ack @ IF
				xclock+ @ tcp_transmit		
			THEN
		; overrides :consume_port

Exciting times, I even know how this is written now. Write the "listen" state and I can start testing all this shit. And whats even better I know how the listen state is to be written to. I know I know look bloody simple, it isn't like that when it hasn't been written.

This gets called because something somewhere thinks it is time for the application to give up. We clear the write queues because the application may be waiting for write queue space. We set the state to #tcps_abort so the application finds out about the sad state when the next write occures. We queue a read packet with an abort for applications that are trying to read data 

 
		m: ( reason --)
			%%tcp_abort_reason !
			#tcps_abort %%tcp_state !
			\ we have to clear out the transmit queues, if a task was
			\ waiting for transmission then this will awake the task
			_return_transmit_queues
			_wake_receiving_task
		; overrides :abort_connection

		m: ( --)
			_out_tcp_state_table %%tcp_state @
			 #tcps_error MIN + @execute
		; method :transmit_action

Deals with sending data out. 

 
		: _tcp_transmit_action ( --)
			\ this gets executed every time tcp level is run
			\ note we look at first item in list
			\ when the execution time moves to the future we are finished.
			BEGIN
				_lock_word
				%tcp_transmit_head @ ?DUP 
			WHILE
				DUP [ %%transmit_time %%transmit_link - ]T LITERAL + @ xclock- @ + 0< not IF
					\ this and following links have not time out
					_unlock_word
					DROP
					EXIT
				THEN
				FALSE OVER [ %%transmit_in_list %%transmit_link - ]T LITERAL + ! 
				\ if further action is required the routine
				\ being called has to relink.
				\ This is done with tcp_tranmit, thatr word can be used by anyone at 
				\ anytime. Net result if we reschedule a high priority task has also
				\ the soonest time will get used.
				\ The unlink will unlock
				DUP unlink_double 
				[ %%transmit_link  ]T LITERAL - 
				\ link object(--
				:transmit_action
			REPEAT
			_unlock_word
		;
			
		m: ( indent --)
			CR DUP SPACES ." tcp_client | " ." Object: " this .h 
			CR DUP SPACES ." lc box  : " %%local_machine @ .h
			              ." rmt box : " %%remote_machine @ .h
			              ." lc port : " %%local_port @ .h
						  ." rmt port: " %%remote_port @ .h
			CR DUP SPACES ." priority: " %%priority @ .h
			              ." state   : " %%tcp_state @ .h
						  ." snd.una : " %%tcp_snd.una @ .h
						  ." snd.nxt : " %%tcp_snd.nxt @ .h

			CR DUP SPACES ." snd.end : " %%tcp_snd.end @ .h
						  ." snd.que : " %%tcp_snd.queue @ .h
						  ." rcv.nxt : " %%tcp_rcv.nxt @ .h
						  ." rcv.used: " %%tcp_rcv.used @ .h

			CR DUP SPACES ." rcv.end : " %%tcp_rcv.end @ .h
			              ." q sent  : " %%tcp_queue_sent .h
						  ." q unsent: " %%tcp_queue_unsent .h
						  ." rcv list: " %%receive_list .h

			CR DUP SPACES ." rexmt   : " %%tcp_rexmt @ .h
		                  ." rtt     : " %%tcp_rtt @ .h
		                  ." smooth  : " %%tcp_rtt_smooth @ .h
			              ." rtt_dev : " %%tcp_rtt_dev @ .h
			CR DUP SPACES ." rcv room: " %%receive_list_room @ .h
			              ." rcv.iss : " %%tcp_rcv.iss @ .h
						  ." snd.is  : " %%tcp_snd.is @ .h

			send
			DROP
		; overrides :print

target_also
&drivers
target_definitions

end_class tcp_client

target_previous_definitions
target_previous


tcp_client class

Head of a linked list of buffers, normally only one present. Can grow quite large if under a syn attack. The timeout routine shrinks it again if the SYN's are not match up be a SYN reply.

tcp_server objects are linked into %syn_timeout_head for the timeout routine. The are linked through %%syn_timeout_link 

 
		ram_variable %syn_timeout_head
		double% instance_variable %%syn_timeout_link

The syn buffers are linked into this head. The is one list per object 

  
		cell% instance_variable %%syn_buffer

This is the number of clients than can be opened but not processed by :listen, to get this far the remote machine must have acked the syn reply we sent.

The server can create differenct client objects. 

 
		cell% instance_variable %%client

		$10 CONSTANT _#client_queue_size
		1 CONSTANT _#client_queue_priorities

		#queue_list_length
		_#transmit_queue_priorities *
		#queue_data_length + bytes% instance_variable %%client_queue 

		m: ( parent--)
			this [parent] :construct
			0 %%syn_buffer !
			_#client_queue_size  _#client_queue_priorities %%client_queue queue_init
			%%syn_timeout_link %syn_timeout_head link_double
			\ the default client created
			[ tcp_client ]T LITERAL %%client !
		; overrides :construct


		: return_syn_buffers ( --)
			%%syn_buffer BEGIN
				DUP @ 
			WHILE
				DUP @ kill_free_buffer
			REPEAT
		;
	

		m:
			%%syn_timeout_link unlink_double
			return_syn_buffers
			this [parent] :destruct
		; overrides :destruct

String can be: 

 
			 /local_port
			 
 
		m: ( addr n mode -- instance )
			%%mode !
			\ addr_port count_port(--
			[CHAR] / remove_leading
			DUP IF \ port speced
				Snumber %%local_port !
			ELSE
				TRUE ABORT" Must suply listen port"
			THEN

			\ Add a tcp demux entry. We are a server we accept
			\ all connections to the port.
			this %%local_port @
			0 0  \ don't care what remove machine 
			0 0  \ don't care what remote port
			\  object local_port remote_ip remote_ip_mask remote_port remote_port_mask (--
			_tcp_add ?DUP IF
				$ABORT
			THEN
			%%demux_structure !
			\ set the state to listen
			#tcps_listen %%tcp_state !
			\ and that is about it. Your code now has to to listen which
			\ will return open objects connected to particular remote machines
			\ and ports. The creation of the object is done int he proto task.
			this
		; overrides :Sopen
listen

The key to Syn attack protection is to use minimum resources on the initial syn and only commit to the channel if our syn is acked.

The timeout routine ages entries. A buffer in the syn buffer is returned to the free buffer pool when all entries in the buffer have timed out. 

 
		: _remove_syn_entry ( addr --)
			zero SWAP _#listen_inuse + W!
		;

		\ under normal operation you do not need a big buffer. If someone is attacking
		\ then things can grow quite large,
		80 _#sys_buffer_user - CONSTANT _#initial_syn_size

		: _find_empty_syn_entry { -- ( addr ) }
			%%syn_buffer 
			BEGIN
				DUP @ 
			WHILE
				\ link(--
				DUP @ DUP buffer_size _#lhead_data DO
					\ link buffer(--
					DUP I + _#listen_inuse + W@ not IF
						I +
						NIP
						UNLOOP 
						EXIT
					THEN
				_#listen_entry_size +LOOP
				NIP
			REPEAT
			\ link(--
			_#initial_syn_size get_free_buffer 
			DUP DUP buffer_size ERASE
			\ link buffer<-
			TUCK SWAP link_double
			_#lhead_data +
		;


		: _find_syn_entry { variable %remote_machine variable %remote_port -- ( addr true| false ) }
			
			%%syn_buffer 
			
			BEGIN
				DUP @ 
			WHILE
				\ link (--
				DUP @ DUP buffer_size _#lhead_data DO
					\ link buffer(--
					DUP I + _#listen_inuse + W@ IF
						DUP I + _#listen_machine + @ 
						%remote_machine @ 
						=
						OVER I + _#listen_port + W@
						%remote_port @ 
						=
						AND IF
							I + 
							NIP
							TRUE
							UNLOOP 
							EXIT
						THEN
					THEN
				_#listen_entry_size +LOOP
				NIP
			REPEAT
			DROP FALSE
		;



		: _add_syn_entry  { ( machine port service_type seq mss--add) }{
			variable %syn_entry }
			_find_empty_syn_entry %syn_entry !
			\ this must be non zero
			TRUE %syn_entry @ _#listen_inuse + W!
			%syn_entry @ _#listen_mss + W!
			%syn_entry @ _#listen_rcv.iss + !
			%syn_entry @ _#listen_st + W!
			%syn_entry @ _#listen_port + W!
			%syn_entry @ _#listen_machine + !
			initial_sequence %syn_entry @ _#listen_send.iss + !
			xclock+ @ %syn_entry @ _#listen_time + !
			%syn_entry @
		;

		: _listen_mss ( addr -- mss)
			\ if remote machine is on other side of gateway
			\ then mss is set to the internet default
			\ if local mss is dependent on the interface
			DUP _#listen_machine + @ 
			SWAP _#listen_st + W@ $1C AND 2 RSHIFT 
			route_get ?DUP IF
				\ The rules are. Make the receive mss as big as you can 
				\ and tell the other end when you send the sync. The send
				\ mss is the default value unless the other end tells us 
				\ otherwise. The mss depend not only on the connection medium 
				\ but alsp on the host being communicated with. The other end
				\ may not be able to handle a mss greater than the min.
				DUP rt_gw + @ not IF
					\ we are talking locally; make mss dependent
					\ on mtu. This is very important for us as the
					\ rti bus has a mtu of 8k
					\ see rfc876 page 5 for justification for this calculation
					rt_interface + @ :@mtu ip_options - 
					#tcp_header_end - 
					EXIT
				ELSE
					DROP
				THEN
			THEN
			#default_mss
		;
				

		: _send_syn_ack ( addr --) 
			%%remote_machine @
			OVER _#listen_st + W@ $1C AND 2 RSHIFT route_get ?DUP IF
				\ syn_entry route_entry(--
				\ The rules are. Make the receive mss as big as you can 
				\ and tell the other end when you send the sync. The send
				\ mss is the default value unless the other end tells us 
				\ otherwise. The mss depend not only on the connection medium 
				\ but alsp on the host being communicated with. The other end
				\ may not be able to handle a mss greater than the min.
				DUP rt_gw + @ not IF
					\ we are talking locally; make mss dependent
					\ on mtu. This is very important for us as the
					\ rti bus has a mtu of 8k
					\ see rfc876 page 5 for justification for this calculation
					DUP rt_interface + @ :@mtu ip_options - 
					#tcp_header_end - %%tcp_rcv.mss !
				THEN
				DROP
			THEN
			\ syn_entry(--
			DUP _#listen_send.iss + @ \ the sequence number

			\ addr send.iss(--
			#rcv_data_buffer
			\ addr send.iss rcv.wnd(--
			\ add one so I ack remote seq
			ROT _#listen_rcv.iss + @ 1+  \ ack the received syn
			\ send.iss rev.wnd rcv.nxt(--
			#tcpf_ack #tcpf_syn OR 
			_send_empty_segment
		;

Setup the object then link it into the completed object queue this is the queue the :listen method looks at. 

 
		: _setup_tcp_client { ( pep addr  --flag) }{
			variable %new_client }
			\ make sure there are not too many links open
			%%client_queue queue_room? not IF
				2DROP
				FALSE
			THEN
			\ it is not allowed to have a parent if it does 
			\ close tries to deal with it
			zero %%client @ heap_object
			%new_client !
			\ pep table_addr (--
			%new_client @ :client_init
			\ (--
			\ we have to force the queue as we cannot destroy the object
			\ in this code. We are in the proto task. The proto task cannot
			\ be put to sleep for the conveniance of anyone. If you look
			\ at the :destruct code for this object you will see it very
			\ much puts the task executing the word to sleep.
			\ :listen waits for objects to be added to this queue. and returns
			\ them. :listen is executed in the server task. Code that uses listen
			\ will normaly start another task.
			%new_client @ [ %%server_link ]T LITERAL + %%client_queue zero enqueue_force  
			TRUE
		;

Even though the syn reply contains data we do not time it out the person calling for the syn has to time us out. We do this to reduce the trouble syn attacks can cause. the timeout routine times out the table entry and shrinks the table if the number of syn is below an acceptable limit.

The segment contained an ack, all that is valid is a responce from the SEQ and ACK we sent. 

 
		: _ack_seg { variable %pep -- }
			%%remote_machine @ %%remote_port @
			\ source_machine source_port(--
			_find_syn_entry 
			
			IF
				\ addr (--
				\ a syn from this port has been received in the past
				\ Does the new packet ack the sequence we sent in reply
				%pep @ ep_ipdata + @ #tcp_ack + @ OVER _#listen_send.iss + @ 1+ = IF
					\ ok remote acked our seq
					\ clear the table entry we are going onto
					\ bigger and better things
				
					%pep @ OVER 
					_setup_tcp_client IF
						\ success now clients problem
						\ addr(--
						_remove_syn_entry
						EXIT
					THEN
					\ failed; to many clients open
					\ unfortunatly have to reset.
					\ We have to be carefull here the reset has to 
					\ ack the sent syn. If you look at
					\ _send_tcp_reset you will see this has
					\ been dealt with by acking the last sequence in packet.
					\
					\ You might say you left it a bit late.
					\ However others may have left in the 
					\ little time we gained
					\ addr(--
					%pep @ _send_tcp_reset
					%pep @ kill_free_buffer
					EXIT
				THEN
				\ addr(--
				\ ack didn't ack our syn.
				\ send it again.
				\ reset has already been dealt with
				\ addr (--
				DUP _#listen_send.iss + @ 1+ \ the sequence number after the SEQ I send
				\ addr send.iss(--
				#rcv_data_buffer
				\ addr send.iss rcv.wnd(--
				\ add one so I ack remote seq
				ROT _#listen_rcv.iss + @ 1+  \ ack the received syn
				\ send.iss rev.wnd rcv.iss(--
				#tcpf_ack 
				_send_empty_segment
				%pep @ kill_free_buffer
				EXIT		 
			THEN
			\ there was no inital sequence. The remote is speaking bullshit
			\ if a reset drop packet; if anything else send a reset.
			%pep @ _send_tcp_reset
			%pep @ kill_free_buffer
		;

		 
		: _syn_seg { variable %pep -- }
			\ if ack is set as well then we are dealing with
			\ a problem client
			%pep @  ep_ipdata + @ #tcp_flags + B@ #tcpf_ack AND IF
				%pep @ _send_tcp_reset
				%pep @ kill_free_buffer
				EXIT
			THEN
			%%remote_machine @ %%remote_port @
			_find_syn_entry IF
				\ addr(--
				\ its ether the same syn or a bloody mess
				\ this will reply to first syn, lets the other end
				\ decide what to do.
				_send_syn_ack 
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ (--
			\ new syn
			%%remote_machine @
			%%remote_port @
			%pep @ [ ep_data ip_tos + ]T LITERAL + B@
			\ remote_machine remote_port st(--
			%pep @ ep_ipdata + @ #tcp_seq + @

			#default_mss %%tcp_snd.mss !
			%pep @ _process_tcp_options IF
				%pep @ kill_free_buffer
				EXIT
			THEN
			%%tcp_snd.mss @
			_add_syn_entry
			\ addr (--
			_send_syn_ack
			%pep @ kill_free_buffer
		;

If the reset is within the window then clear the syn entry and call everything off. If the reset is outside the window send an ack for the received syn. 

 
		: _reset_seg { variable %pep -- }
			%%remote_machine @ %%remote_port @ 
			\ source_machine destination_machine(--
			 _find_syn_entry IF
				\ addr(--
				\ this is in responce to our SYN ACK
				\ as the ack was set the reset sequence should 
				\ be equal according to standard. We will accept
				\ any responce in window.
				%pep @ ep_ipdata + @ #tcp_ack + @ 
				OVER _#listen_send.iss + @ 
				2DUP = 
				-rot 1+ = OR IF
					_remove_syn_entry
					%pep @ kill_free_buffer
					EXIT
				THEN
				DROP
			THEN
			%pep @ kill_free_buffer
		;
function for each state

The listen state didn't have to implemented in the client. We over ride the entry in the client table. The server only sits in the listen state. The server waits until the we receive a pep that has enought data to put the client in the stablised state and calls :client_init against a new client object to have that happen. So it is the client that runs through new states. The serve just stays in listen. 

 
		: _in_tcps_listen ( pep --)
			DUP [ ep_data ip_dst + ]T LITERAL + @ 
			%%local_machine !
			DUP [ ep_data ip_src + ]T LITERAL + @ 
			%%remote_machine !
			DUP ep_ipdata + @ #tcp_src + W@  
			
			%%remote_port !
			\ pep(--
			DUP ep_ipdata + @ #tcp_flags + B@
			DUP #tcpf_rst AND IF
				DROP 
				_reset_seg
				EXIT
			THEN
			DUP #tcpf_syn AND IF
				DROP 
				_syn_seg
				EXIT
			THEN
			DUP #tcpf_ack AND IF
				DROP 
				_ack_seg
				EXIT
			THEN
			DROP
			\ other it really is a nonsence packet if we get here 
			\ just drop it.
			kill_free_buffer
		;

		' _in_tcps_listen _in_tcp_state_table #tcps_listen  + t!

Transmit task is not used for this state. 

 

		: _out_tcps_listen ( --)
		;

		' _out_tcps_listen _out_tcp_state_table #tcps_listen  + t!

Pretty simple hay. 

 
		m: ( -- obj )
			%%client_queue xawait
			%%client_queue dequeue	
			[ %%server_link ]T LITERAL - 
		; overrides :listen

When we are acking a syn so we are also sending data as the syn is part of the sequence space. We however don't retransmit, it is up to the client to do that if it is serious about getting a connection. 

 
		m: ( --) { -- }{
			variable %entries_used }
			%%syn_buffer 
			BEGIN
				DUP @
			WHILE 
				DUP @
				0 %entries_used !
				\ set true by high level task if it adds an entry to this list
				zero OVER _#lhead_entries_added + !
				\ link buffer(--
				DUP buffer_size _#lhead_data DO
					DUP I + _#listen_inuse + W@ IF
							1 %entries_used +!
							DUP I + _#listen_time + @ _#demux_live_time +  
							xclock- @ + 0< IF
								\ time to erase
								DUP I + _remove_syn_entry
								-1 %entries_used +!
							THEN
						THEN
				_#listen_entry_size +LOOP
				\ link addr(--
				%entries_used @ not 
				_lock_word
				OVER _#lhead_entries_added + @ not AND IF
					\ this will unlock
					 unlink_double
				ELSE
					_unlock_word
					NIP
				THEN
				\ link(--
			REPEAT
			\ link(--
			DROP
		; method :syn_timeout

		: _syn_timeout ( --)
			%syn_timeout_head
			BEGIN
				@ ?DUP
			WHILE
				DUP [ %%syn_timeout_link  ]T LITERAL - 
				\ link object(--
				:syn_timeout
			REPEAT
		;

Set the client object the server is to create. It is best to base the object on tcp_client, set tcp_telnet fined next. 

 
		m: ( addr --)
			%%client !
		; method :client!

		m: ( indent --)
			CR DUP SPACES ." tcp_server | " ." Object: " this .h 
			CR DUP SPACES ." lc box  : " %%local_machine @ .h
			              ." lc port : " %%local_port @ .h
			CR DUP SPACES ." state   : " %%tcp_state @ .h
			              ." syn_buff: " %%syn_buffer @ .h
			              ." clients : " %%client_queue .h

			send
			DROP
		; overrides :print


target_also
&drivers
target_definitions

end_class tcp_server

target_previous_definitions
target_previous
telnet server
RFC854 telnet
 


terminal class

		\ normal character presentation
		| : _write_string ( handle addr --)
			COUNT  
			ROT :write 
		 ;

		| CREATE _$normal $041B5B30 t, $6D00 tw,
		m: ( object --)
			_$normal _write_string
		; overrides ::normal

		| CREATE _$rev $041B5B37 t, $6D00 tw,
		m: ( object --)
			_$rev _write_string
		; overrides ::rev

		| CREATE _$blink $041B5B35 t, $6D00 tw,
		m: ( object --)
			_$blink _write_string
		; overrides ::blink

		| CREATE _$dim $041B5B31 t, $6D00 tw,
		m: ( object --)
			_$dim _write_string
		; overrides ::dim


		| CREATE _$udl $041B5B34 t, $6D00 tw,
		m: ( object --)
			_$udl _write_string
		; overrides ::udl

		| CREATE _$dim&blink $061B5B31 t, $3B356D00 t,
		m: ( object --)
			_$dim&blink _write_string
		; overrides ::dim&blink

		| CREATE _$rev&blink $061B5B37 t, $3B356D00 t,
		m: ( object --)
			_$rev&blink _write_string
		; overrides ::rev&blink

		| CREATE _$rev&dim $061B5B37 t, $3B316D00 t,
		m: ( object --)
			_$rev&dim _write_string
		; overrides ::rev&dim

		| CREATE _$rev&udl $061B5B34 t, $3B376D00 t,
		m: ( object --)
			_$rev&udl _write_string
		; overrides ::rev&udl


		| CREATE _$rev&dim&blink $081B5B37 t, $3B313B35 t, $6D00 tw,
		m: ( object --)
			_$rev&dim&blink _write_string
		; overrides ::rev&dim&blink


		| CREATE _$rev&dim&udl $081B5B37 t, $3B313B35 t, $6D00 tw,
		m: ( object --)
			_$rev&dim&udl _write_string
		; overrides ::rev&dim&udl


		\ unix likes, unix needs a two character terminator
		| CREATE _$crlf  $020D0A00 t,  
		m: ( object -- )
			_$crlf _write_string
			0 %%character !
			1 %%line +!
		; overrides ::cr

		| CREATE _$ansi_page $041B5B32 t, 4A00 tw,	
		m: ( object--)
			_$ansi_page _write_string
			1 %%page +!
			0 %%character !
			0 %%line !
		; overrides ::page

		| CREATE _$csi $021B5B00 t,
				
		\ terminal class has to be telnet specific.
		| : _nnn { ( n ) variable %handle -- }
			BASE @ >R DECIMAL
			1+
			zero #$buffer get_buffer
			buffer #$buffer [# # # # #]  %handle @ :write
			kill_buffer
			R> BASE !
		; 

		| : _control_char_write { ( char handle)  -- }{
			variable %char_buffer }
			SWAP %char_buffer C!
			%char_buffer 01 ROT :write
		;
		
		m: { ( lin col) variable %handle -- }

			%%character_max @ MIN
			SWAP %%line_max @ MIN 
			SWAP

			2DUP
			%handle @ _$csi _write_string
			SWAP %handle @  _nnn
			$3B %handle @ _control_char_write
			%handle @ _nnn
			$48 %handle @ _control_char_write 			
			%%character ! 
			%%line !
		; overrides ::tab
		
end_class tcp_terminal



tcp_client class	

			cell% instance_variable %%show_telnet_options
			cell% instance_variable %%ga_off
			cell% instance_variable %%naws

The terminal type has to be tcp_terminal 

 
			m:
			this [parent] :construct
			%%terminal @ IF
				%%terminal @ heap_object_free
			THEN
			tcp_terminal heap_object
			%%terminal !
			TRUE %%show_telnet_options !
			FALSE %%ga_off !
			FALSE %%naws !
			; overrides :construct

			m:
				this [parent] :destruct
			; overrides :destruct


			m:
				%%show_telnet_options @ not %%show_telnet_options !
			; method :show_options

The control sequence all start with IAC. 

			example: Suppress ga
			[255][251][003]    _#iac _#will _#opt_ga
Options

From RFC1700 TCP
Also see IANA Numbers
http://www.iana.org/numbers.html 

 		
\ Options         Name                                                 References
\ -------         -----------------------                              ----------
	#00 CONSTANT _#opt_binary     \ 00 Binary Transmission              RFC856 TCP
	#01 CONSTANT _#opt_echo       \ 01 Echo                             RFC857 TCP
\	#02 CONSTANT _#opt_rec        \ 02 Reconnection                     [NIC50005,JBP]
	#03 CONSTANT _#opt_no_ga      \ 03 Suppress Go Ahead                RFC858 TCP
\	#04 CONSTANT _#opt_app_mess   \ 04 Approx Message Size Negotiation  [ETHERNET,JBP]
	#05 CONSTANT _#opt_status     \ 05 Status                           RFC859 TCP
	#06 CONSTANT _#opt_tm         \ 06 Timing Mark                      RFC860 TCP
\	#07 CONSTANT _#opt_rmt_echo   \ 07 Remote Controlled Trans and Echo RFC726 TCP
\	#08 CONSTANT _#opt_line_width \ 08 Output Line Width                [NIC50005,JBP]
\	#09 CONSTANT _#opt_page_size  \ 09 Output Page Size                 [NIC50005,JBP]
\	#10 CONSTANT _#opt_cr_disp    \ 0A Output CR Disposition            RFC652 TCP
\	#11 CONSTANT _#opt_horz_tab   \ 0B Output Horizontal Tab Stops      RFC653 TCP
\	#12 CONSTANT _#opt_horz_dsip  \ 0C Output Horizontal Tab DispositionRFC654 TCP
\	#13 CONSTANT _#opt_form_disp  \ 0D Output Formfeed Disposition      RFC655 TCP
\	#14 CONSTANT _#opt_vert_tab   \ 0E Output Vertical Tabstops         RFC656 TCP
\	#15 CONSTANT _#opt_vert_disp  \ 0F Output Vertical Tab Disposition  RFC657 TCP
\	#16 CONSTANT _#opr_line_disp  \ 10 Output Linefeed Disposition      RFC657 TCP
\	#17 CONSTANT _#opt_ext_acsii  \ 11 Extended ASCII                   RFC659 TCP
\	#18 CONSTANT _#opt_logoff     \ 12 Logout                           RFC727 TCP
\	#19 CONSTANT _#opt_byte_macro \ 13 Byte Macro                       RFC735 TCP
\	#20 CONSTANT _#opt_date_entry \ 14 Data Entry Terminal              RFC1043 TCP
\	#21 CONSTANT _#opt_supdup     \ 15 SUPDUP                           RFC736 TCP
\	#22 CONSTANT _#opt_supbup_out \ 16 SUPDUP Output                    RFC749 TCP
\	#23 CONSTANT _#opt_snd_loc    \ 17 Send Location                    RFC779 TCP
	#24 CONSTANT _#opt_term_typ   \ 18 Terminal Type                    RFC1091 TCP
	#25 CONSTANT _#opt_eor        \ 19 end of Record                    RFC885 TCP
\	#26 CONSTANT _#opt_tacacs_id  \ 1A TACACS User Identification       RFC927 TCP
\	#27 CONSTANT _#opt_op_mark    \ 1B Output Marking                   RFC933 TCP
\	#28 CONSTANT _#opt_location   \ 1C Terminal Location Number         RFC946 TCP
\	#29 CONSTANT _#opt_3270       \ 1D Telnet 3270 Regime               RFC1041 TCP
\	#30 CONSTANT _#opt_x.3        \ 1E X.3 PAD                          RFC1053 TCP
	#31 CONSTANT _#opt_win_size   \ 1F Negotiate About Window Size      RFC1073 TCP
\	#32 CONSTANT _#opt_term_speed \ 20 Terminal Speed                   RFC1079 TCP
\	#33 CONSTANT _#opt_flow_cnt   \ 21 Remote Flow Control              RFC1373 TCP
	#34 CONSTANT _#opt_linemode   \ 22 Linemode                         RFC1184 TCP
\	#35 CONSTANT _#opt_x_loc      \ 23 X Display Location               RFC1096 TCP
\	#36 CONSTANT _#opt_env_opt    \ 24 Environment Option               RFC1408 TCP
\	#37 CONSTANT _#opt_auth       \ 25 Authentication Option            RFC1409 TCP
\	#38 CONSTANT _#opt_enc1       \ 26 Encryption Option                [DB14]
\	#39 CONSTANT _#opt_enc2       \ 27 New Environment Option           RFC1572 TCP

RFC854 telnet
RFC1116 telnet line mode

 
		#255 CONSTANT _#iac       \ FF
		#254 CONSTANT _#don't     \ FE
		#253 CONSTANT _#do        \ FD
		#252 CONSTANT _#won't     \ FC
		#251 CONSTANT _#will      \ FB
		#250 CONSTANT _#sb        \ 
\		#249 CONSTANT _#ga
\		#248 CONSTANT _#el
\		#247 CONSTANT _#ec
\		#246 CONSTANT _#ayt
\		#245 CONSTANT _#ao
\		#244 CONSTANT _#ip
\		#243 CONSTANT _#brk
\		#242 CONSTANT _#dmark
\		#241 CONSTANT _#nop
		#240 CONSTANT _#se
\		#239 CONSTANT _#eor
\		#238 CONSTANT _#abort
		#237 CONSTANT _#end
		#236 CONSTANT _#table_start_char
null operation [255][0->238]
 
		: _null_operation ( -- false)
			FALSE
		;

This is what linux sends 

 
		: _end ( -- _#end_eof terminator_flag data_flag )
			#end_eof TRUE TRUE
		;
EOR [255][239]

You will find a reference right at the end of RFC885 TCP
Note that if you have not negotiated it's use you should treat the EOR record as a not. Pray tell, why. Why would you send it it it is not a EOR, are the people writing the standard stupid eough to give EOR another meaning. 

 
		: _eor ( -- _#cr terminator_flag data_flag)
			#cr TRUE TRUE
		;
SE [255][240]

This code should not see this, if we do input is not correctly structureed. Damages is done and no purpose is gained by complaining. 

 
		: _se ( --false)
			\ we get here damage has been done
			FALSE
		;
NOP [255][241]

No operation 

 
		: _nop ( -- false)
			FALSE
		;
DMARK [255][242]

Mark the urgent data end. We should not see this as it is the problem of others to read the urgent data up to the mark. 

 
		: _dmark ( --false)
			this :clear
			FALSE
		;
BRK [255][243]

The "break" signal. 

 
		: _brk ( -- false)
			FALSE

		;
BRK [255][244]

Interrupt process. 

 
		: _ip ( -- false
			TRUE @u activation_^c_set W!
			FALSE
		;
AO [255][243]

Abort output is not supported 

 
		: _ao ( -- false
			FALSE
		;
AYT [255][246]

Are you there 

 
		CREATE $patience ," Yes I am"
		: _ayt ( -- false)
			$patience COUNT this :write
			this :flush_file
			FALSE
		;
EC [255][247]

erase character 

 
		: _ec ( --false )
			FALSE
		;
EL [255][248]

erase line 

 
		: _el ( --false)
			FALSE
		;
GA [255][249]

Go ahead 

 
		: _ga ( --false)
			FALSE
		;
SB [255][250]

Start options sub negotiations. At this state no options that require sub negotiations are supported so we simple read in the data stream until we see [255] [240] 

 

		: _sub_not_used ( options-- false|data flag true)
			DROP
			BEGIN
				_get_data IF
					\ reached end of stream never going to get an answer
					TRUE TRUE
					EXIT
				THEN
				_#iac = IF
					_get_data IF
						\ reached end of stream never going to get an answer
						TRUE TRUE
						EXIT
					THEN
					_#se = IF
						FALSE
						EXIT
					THEN
				THEN
			AGAIN
		;
		\ IAC|SB|NAWS|char_hb|char_lb|line_hb|line_lb|IAC|SE
		\ If the data is IAC it has to be escaped with IAC
		: _sub_naws ( options-- false|data flag true)
			DROP
			\ two bytes of data, we still have to deal with #iac
			zero
			2 0 DO
				8 LSHIFT
				_get_data IF
					\ reached end of stream never going to get an answer
					DROP UNLOOP
					TRUE TRUE
					EXIT
				THEN
				DUP _#iac = IF
					DROP
					_get_data IF
						\ reached end of stream never going to get an answer
						DROP UNLOOP
						TRUE TRUE
						EXIT
					THEN
					DUP _#se = IF
						\ value character(--
						2DROP 
						UNLOOP
						FALSE
						EXIT
					THEN
				THEN
				\ value data(--
				+
			LOOP
			?DUP IF
				1- \ if is the maximum value tab can take so it is zero based
				this :character_max !
			THEN
			zero
			2 0 DO
				8 LSHIFT
				_get_data IF
					\ reached end of stream never going to get an answer
					DROP UNLOOP
					TRUE TRUE
					EXIT
				THEN
				DUP _#iac = IF
					DROP
					_get_data IF
						\ reached end of stream never going to get an answer
						DROP UNLOOP
						TRUE TRUE
						EXIT
					THEN
					DUP _#se = IF
						2DROP 
						UNLOOP
						FALSE
						EXIT
					THEN
				THEN
				\ data
				+
			LOOP
			?DUP IF
				1 - \ max value tab can take so it is zero based
				this :line_max !
			THEN
			\ eat rest of sub option string
			zero _sub_not_used
		;



		CREATE _sub_vector
			#41 tw,
			' _sub_not_used          t,  \ 00
			' _sub_not_used          t,  \ 01
			' _sub_not_used          t,  \ 02
			' _sub_not_used          t,  \ 03
			' _sub_not_used          t,  \ 04
			' _sub_not_used          t,  \ 05
			' _sub_not_used          t,  \ 06
			' _sub_not_used          t,  \ 07
			' _sub_not_used          t,  \ 08
			' _sub_not_used          t,  \ 09
		
			' _sub_not_used          t,  \ 10
			' _sub_not_used          t,  \ 11
			' _sub_not_used          t,  \ 12
			' _sub_not_used          t,  \ 13
			' _sub_not_used          t,  \ 14
			' _sub_not_used          t,  \ 15
			' _sub_not_used          t,  \ 16
			' _sub_not_used          t,  \ 17
			' _sub_not_used          t,  \ 18
			' _sub_not_used          t,  \ 19

			' _sub_not_used          t,  \ 20
			' _sub_not_used          t,  \ 21
			' _sub_not_used          t,  \ 22
			' _sub_not_used          t,  \ 23
			' _sub_not_used          t,  \ 24
			' _sub_not_used          t,  \ 25
			' _sub_not_used          t,  \ 26
			' _sub_not_used          t,  \ 27
			' _sub_not_used          t,  \ 28
			' _sub_not_used          t,  \ 29

			' _sub_not_used          t,  \ 30
			' _sub_naws              t,  \ 31
			' _sub_not_used          t,  \ 32
			' _sub_not_used          t,  \ 33
			' _sub_not_used          t,  \ 34
			' _sub_not_used          t,  \ 35
			' _sub_not_used          t,  \ 36
			' _sub_not_used          t,  \ 37
			' _sub_not_used          t,  \ 38
			' _sub_not_used          t,  \ 39

			' _sub_not_used          t,  \ 40

		: _sb ( -- false| data flag flag)			
				_get_data IF
					\ reached end of stream never going to get an answer
					TRUE TRUE
					EXIT
				THEN
				\ char
				%%show_telnet_options @ IF
					." server rcvd sub option " DUP . CR
				THEN
				DUP _sub_vector vector
		;
WILL [255][251]

Receiving a WILL, we have to reply with DO or DON'T 

 
		: _send_do { ( option --) }{
			variable %buffer }
			_#iac  %buffer char!
			_#do   %buffer 1 CHARS + char!
			%buffer 2 CHARS + char!
			%buffer 3 this :write
		;


		: _send_don't { ( option --) }{
				variable %buffer }
			_#iac     %buffer char!
			_#don't   %buffer 1 CHARS + char!
			          %buffer 2 CHARS + char!
			%buffer 3 this :write
		;

		: _send_will { ( option --) }{
				variable %buffer }
			_#iac     %buffer char!
			_#will   %buffer 1 CHARS + char!
			          %buffer 2 CHARS + char!
			%buffer 3 this :write
		;

		: _will_don't ( option -- false)
			_send_don't
			FALSE
		;

		: _will_suppress_ga ( option -- false)
			DROP
			%%ga_off @ not IF
				TRUE %%ga_off !
				_#opt_no_ga _send_do
			THEN
			FALSE
		;
		
		: _will_naws ( option -- false)
			%%naws @ not IF
				TRUE %%naws !
				DUP _send_do
			THEN
			DROP
			FALSE
		;





		CREATE _will_vector
			#41 tw,
			' _will_don't          t,  \ 00
			' _will_don't          t,  \ 01
			' _will_don't          t,  \ 02
			' _will_suppress_ga    t,  \ 03
			' _will_don't          t,  \ 04
			' _will_don't          t,  \ 05
			' _will_don't          t,  \ 06
			' _will_don't          t,  \ 07
			' _will_don't          t,  \ 08
			' _will_don't          t,  \ 09
		
			' _will_don't          t,  \ 10
			' _will_don't          t,  \ 11
			' _will_don't          t,  \ 12
			' _will_don't          t,  \ 13
			' _will_don't          t,  \ 14
			' _will_don't          t,  \ 15
			' _will_don't          t,  \ 16
			' _will_don't          t,  \ 17
			' _will_don't          t,  \ 18
			' _will_don't          t,  \ 19

			' _will_don't          t,  \ 20
			' _will_don't          t,  \ 21
			' _will_don't          t,  \ 22
			' _will_don't          t,  \ 23
			' _will_don't          t,  \ 24
			' _will_don't          t,  \ 25
			' _will_don't          t,  \ 26
			' _will_don't          t,  \ 27
			' _will_don't          t,  \ 28
			' _will_don't          t,  \ 29

			' _will_don't          t,  \ 30
			' _will_naws           t,  \ 31
			' _will_don't          t,  \ 32
			' _will_don't          t,  \ 33
			' _will_don't           t,  \ 34
			' _will_don't          t,  \ 35
			' _will_don't          t,  \ 36
			' _will_don't          t,  \ 37
			' _will_don't          t,  \ 38
			' _will_don't          t,  \ 39

			' _will_don't          t,  \ 40

		: _will ( -- false| data flag flag )
			\ get the option
			_get_data IF
				\ terminator
				TRUE TRUE 
				EXIT
			THEN
			%%show_telnet_options @ IF
				." server rcvd WILL " DUP . CR
			THEN
			DUP _will_vector vector
		;
WON'T [255][252]

In a responce to a will we dond a won't, if we won't 

 
		\ I didn't issue a do so I have no idea.
		: _won't_?? ( option -- false)
			DROP
			FALSE
		;

		CREATE _won't_vector
			#41 tw,
			' _won't_??          t,  \ 00
			' _won't_??          t,  \ 01
			' _won't_??          t,  \ 02
			' _won't_??          t,  \ 03
			' _won't_??          t,  \ 04
			' _won't_??          t,  \ 05
			' _won't_??          t,  \ 06
			' _won't_??          t,  \ 07
			' _won't_??          t,  \ 08
			' _won't_??          t,  \ 09
		
			' _won't_??          t,  \ 10
			' _won't_??          t,  \ 11
			' _won't_??          t,  \ 12
			' _won't_??          t,  \ 13
			' _won't_??          t,  \ 14
			' _won't_??          t,  \ 15
			' _won't_??          t,  \ 16
			' _won't_??          t,  \ 17
			' _won't_??          t,  \ 18
			' _won't_??          t,  \ 19

			' _won't_??          t,  \ 20
			' _won't_??          t,  \ 21
			' _won't_??          t,  \ 22
			' _won't_??          t,  \ 23
			' _won't_??          t,  \ 24
			' _won't_??          t,  \ 25
			' _won't_??          t,  \ 26
			' _won't_??          t,  \ 27
			' _won't_??          t,  \ 28
			' _won't_??          t,  \ 29

			' _won't_??          t,  \ 30
			' _won't_??          t,  \ 31
			' _won't_??          t,  \ 32
			' _won't_??          t,  \ 33
			' _won't_??          t,  \ 34
			' _won't_??          t,  \ 35
			' _won't_??          t,  \ 36
			' _won't_??          t,  \ 37
			' _won't_??          t,  \ 38
			' _won't_??          t,  \ 39

			' _won't_??          t,  \ 40

		\ we have issued a do and got a won't
		: _won't ( --)
			_get_data IF
				\ terminator
				TRUE TRUE EXIT
			THEN
			%%show_telnet_options @ IF
				." server received WON'T " DUP . CR
			THEN
			DUP _won't_vector vector
		;
DO [255][253]

In a responce to a will send a do, if we want and don't if not.

We are receiving. Request by other party to use option ABC. If we set the option we have to respond with will or won't 

 
		: _send_won't { ( option --) }{
				variable %buffer }
			_#iac     %buffer char!
			_#won't   %buffer 1 CHARS + char!
			          %buffer 2 CHARS + char!
			%buffer 3 this :write
		;
		


		: _do_won't ( option --false)
			_send_won't
			FALSE
		;
		
		: _do_will ( option -- false)
			_send_will
			FALSE
		;


		: _do_suppress_ga ( option -- false)
				TRUE %%ga_off !
				_do_will
		;

		
		CREATE _do_vector
			#41 tw,
			' _do_won't          t,  \ 00
			' _do_won't          t,  \ 01
			' _do_won't          t,  \ 02
			' _do_won't          t,  \ 03
			' _do_won't          t,  \ 04
			' _do_won't          t,  \ 05
			' _do_will           t,  \ 06 We will suppress go ahead, whats more we won't inseat a null.
			' _do_won't          t,  \ 07
			' _do_won't          t,  \ 08
			' _do_won't          t,  \ 09
		
			' _do_won't          t,  \ 10
			' _do_won't          t,  \ 11
			' _do_won't          t,  \ 12
			' _do_won't          t,  \ 13
			' _do_won't          t,  \ 14
			' _do_won't          t,  \ 15
			' _do_won't          t,  \ 16
			' _do_won't          t,  \ 17
			' _do_won't          t,  \ 18
			' _do_won't          t,  \ 19

			' _do_won't          t,  \ 20
			' _do_won't          t,  \ 21
			' _do_won't          t,  \ 22
			' _do_won't          t,  \ 23
			' _do_won't          t,  \ 24
			' _do_won't          t,  \ 25
			' _do_won't          t,  \ 26
			' _do_won't          t,  \ 27
			' _do_won't          t,  \ 28
			' _do_won't          t,  \ 29

			' _do_won't          t,  \ 30
			' _do_won't          t,  \ 31 not a server function, we need to send a do.
			' _do_won't          t,  \ 32
			' _do_won't          t,  \ 33
			' _do_won't          t,  \ 34
			' _do_won't          t,  \ 35
			' _do_won't          t,  \ 36
			' _do_won't          t,  \ 37
			' _do_won't          t,  \ 38
			' _do_won't          t,  \ 39

			' _do_won't          t,  \ 40


		: _do ( -- false| data flag flag )
			_get_data IF
				\ terminator
				TRUE TRUE
				EXIT
			THEN
			%%show_telnet_options @ IF
				." server rcvd DO " DUP . CR
			THEN
			DUP _do_vector vector
		;
DON'T [255][254]

In a responce to a will send a do, if we want and don't if not. 

 
		: _don't_??  ( option -- flag)
			DROP
			FALSE
		;


		CREATE _don't_vector
			#41 tw,
			' _don't_??          t,  \ 00
			' _don't_??          t,  \ 01
			' _don't_??          t,  \ 02
			' _don't_??          t,  \ 03
			' _don't_??          t,  \ 04
			' _don't_??          t,  \ 05
			' _don't_??          t,  \ 06
			' _don't_??          t,  \ 07
			' _don't_??          t,  \ 08
			' _don't_??          t,  \ 09
		
			' _don't_??          t,  \ 10
			' _don't_??          t,  \ 11
			' _don't_??          t,  \ 12
			' _don't_??          t,  \ 13
			' _don't_??          t,  \ 14
			' _don't_??          t,  \ 15
			' _don't_??          t,  \ 16
			' _don't_??          t,  \ 17
			' _don't_??          t,  \ 18
			' _don't_??          t,  \ 19

			' _don't_??          t,  \ 20
			' _don't_??          t,  \ 21
			' _don't_??          t,  \ 22
			' _don't_??          t,  \ 23
			' _don't_??          t,  \ 24
			' _don't_??          t,  \ 25
			' _don't_??          t,  \ 26
			' _don't_??          t,  \ 27
			' _don't_??          t,  \ 28
			' _don't_??          t,  \ 29

			' _don't_??          t,  \ 30
			' _don't_??          t,  \ 31
			' _don't_??          t,  \ 32
			' _don't_??          t,  \ 33
			' _don't_??          t,  \ 34
			' _don't_??          t,  \ 35
			' _don't_??          t,  \ 36
			' _don't_??          t,  \ 37
			' _don't_??          t,  \ 38
			' _don't_??          t,  \ 39

			' _don't_??          t,  \ 40



		\ we have issued a do and got a won't
		: _don't ( --)
			." in don't"
			_get_data IF
				\ terminator
				TRUE TRUE EXIT
			THEN
			%%show_telnet_options @ IF
				." server rcvd DON'T " DUP . CR
			THEN
			DUP _don't_vector vector
		;
IAC [255][255]

Dedcode as character 255 

 

		\ #iac #iac --> #iac
		: _iac ( -- char terminator_flag data_flag | false )
			_#iac FALSE TRUE
		;



		CREATE _char_vector_table
			$12 tw, \ number of entries
			' _null_operation t,              \ 0 ->236
			' _end t,                         \ 237
			' _null_operation t,              \ 238
			' _eor t,                         \ 239
			' _se t, ( should never be used)  \ 240  F0
			' _nop t,                         \ 241  F1
			' _dmark t,                       \ 242  F2
			' _brk t,                         \ 243  F3
			' _ip t,                          \ 244  F4
			' _ao t,                          \ 245  F5
			' _ayt t,                         \ 246  F6
			' _ec t,                          \ 247  F7
			' _el t,                          \ 248  F8
			' _ga t,                          \ 249  F9
			' _sb t,                          \ 250  FA
			' _will t,                        \ 251  FB
			' _won't t,                       \ 252  FC
			' _do    t,                       \ 253  FD
			' _don't t,                       \ 254  FE
			' _iac t,                         \ 255  FF

		: _telnet_control ( char -- char terminator_flag data_flag | false )
			DUP _#iac <> IF
				FALSE \ it is not a terminator as we using data already received 
				TRUE 
				EXIT
			THEN
			\ well we have a iac;  
			\ a control character follows drop iac and get control code
			DROP
			\ if we a told it is a terminator the
			\ input stream has finished
			_get_data IF
				\ it was a terminator and it was data
				TRUE TRUE
				EXIT
			THEN
			\ char(--
			_#table_start_char -
			zero MAX
			_char_vector_table vector
		;

		: _store_a_char&echo  ( addr num char --addr num)
			DUP #lf = IF
				DROP
				EXIT
			THEN
			jump char!
			SWAP
			1 CHARS +
			SWAP 
			1 -
		;


		: _read_telnet_stream ( addr1 num1 -- addr2 num2 )
			\ if count is one we are in serious trouble ad can't store
			\ terminator but don't complain
			BEGIN
				\ addr1 num(--
				\ if the count is one of the termination count
				\ we cannot use it, we have to leave room for the
				\ terminator that indicates we ran out of room.
				\ addr char(--
				_get_data IF
					\ a terminator
					_store_a_char
					EXIT
				THEN
				\ addr num char(--
				DUP eot? IF
					\ addr num char(--
					_store_a_char
					\ addr num (-- 
					EXIT
				THEN
				\ addr num char(--
				\ if it was control then there is nothing to store
				\ in output stream.
				_telnet_control IF \ we have data
					IF \ it is a terminator
						_store_a_char
						EXIT
					THEN
					\ leave room for terminator
					OVER 2 < IF
						_unget_character
						\ addr num (--
						#end_count _store_a_char
						EXIT
					THEN	
					\ addr num char(--
					_store_a_char&echo
				THEN
			AGAIN
		;

		  		
		m:  ( addr len -- len)
			OVER >R 
			_read_tcp
			R> OVER + char@ 
			#end_eof = IF
				(end_task) @ 'abort ! ABORT
			THEN
		; overrides :read

		\ flag is false if all is finished
		\ This read_line is for telnet.
		m:  { ( addr len -- len flag) }{
				variable %len 
				variable %addr }
			\ zero is a problem as we need room to store the terminator
			DUP not IF
				2DROP zero TRUE 
			THEN


			DUP %len !
			OVER %addr !

			\ addr len(--
			_read_telnet_stream
			\ addr1 len1(--
			NIP %addr @ SWAP
			\ addr len1(--
			%len @ SWAP -
			\ addr len3(--
			this :termination>code
			\ len4 flag(--
			\ close, but even worse destroy task. 
			DUP not IF
				(end_task) @ 'abort ! ABORT
			THEN
		; overrides :read_line
			
		: _echo_on ( --)
		;

		: _echo_off ( --)
		;

		CREATE control_vectors
			02 tw,
			' _echo_on  t,
			' _echo_off t,
		
		 m: ( code --)
			control_vectors vector
		; overrides :!control


		m: ( indent --)
			CR DUP SPACES ." tcp_telnet | " ." Object: " this .h 
			CR DUP SPACES ." lc box  : " %%local_machine @ .h
			              ." rmt box : " %%remote_machine @ .h
			              ." lc port : " %%local_port @ .h
						  ." rmt port: " %%remote_port @ .h
			CR DUP SPACES ." priority: " %%priority @ .h
			              ." state   : " %%tcp_state @ .h
						  ." snd.una : " %%tcp_snd.una @ .h
						  ." snd.nxt : " %%tcp_snd.nxt @ .h

			CR DUP SPACES ." snd.end : " %%tcp_snd.end @ .h
						  ." snd.que : " %%tcp_snd.queue @ .h
						  ." rcv.nxt : " %%tcp_rcv.nxt @ .h
						  ." rcv.used: " %%tcp_rcv.used @ .h

			CR DUP SPACES ." rcv.end : " %%tcp_rcv.end @ .h
			              ." q sent  : " %%tcp_queue_sent .h
						  ." q unsent: " %%tcp_queue_unsent .h
						  ." rcv list: " %%receive_list .h

			CR DUP SPACES ." rexmt   : " %%tcp_rexmt @ .h
		                  ." rtt     : " %%tcp_rtt @ .h
		                  ." smooth  : " %%tcp_rtt_smooth @ .h
			              ." rtt_dev : " %%tcp_rtt_dev @ .h
			CR DUP SPACES ." rcv room: " %%receive_list_room @ .h
			              ." rcv.iss : " %%tcp_rcv.iss @ .h
						  ." snd.is  : " %%tcp_snd.is @ .h
						  ." rcv room: " %%receive_list_room @ .h
			send
			DROP
		; overrides :print



target_also
&drivers
target_definitions


end_class tcp_telnet

target_previous_definitions
target_previous
./version081/tcp/telnet_server.html0100777000000000000000000011423507300314373016202 0ustar rootroot COLDFORTH KERNEL 
 
			

tcp_client class	


			cell% instance_variable %%show_telnet_options
			cell% instance_variable %%naws
			cell% instance_variable %%sent_will
			cell% instance_variable %%linemode
			cell% instance_variable %%use_line
			cell% instance_variable %%echo_do
			cell% instance_variable %%^c_state


			\ the last task to send becomes the ^c task.
			cell% instance_variable %%^c
			\ set if client wants us to echo

The terminal type has to be ansi_class 

 
			m:
			this [parent] :construct
			%%terminal @ IF
				%%terminal @ heap_object_free
			THEN
			ansi_class heap_object
			%%terminal !
			FALSE %%show_telnet_options !
			FALSE %%naws !
			FALSE %%linemode !
			FALSE %%use_line !
			TRUE  %%echo_do !
			; overrides :construct

			m:
				this [parent] :destruct
			; overrides :destruct


			m:
				%%show_telnet_options @ not %%show_telnet_options !
			; method :show_options

The control sequence all start with IAC. 

			example: Suppress ga
			[255][251][003]    _#iac _#will _#opt_ga
Options

From RFC1700 TCP
Also see IANA Numbers
http://www.iana.org/numbers.html 

 		
\ Options         Name                                                 References
\ -------         -----------------------                              ----------
	#00 CONSTANT _#opt_binary     \ 00 Binary Transmission              RFC856 TCP
	#01 CONSTANT _#opt_echo       \ 01 Echo                             RFC857 TCP
\	#02 CONSTANT _#opt_rec        \ 02 Reconnection                     [NIC50005,JBP]
	#03 CONSTANT _#opt_no_ga      \ 03 Suppress Go Ahead                RFC858 TCP
\	#04 CONSTANT _#opt_app_mess   \ 04 Approx Message Size Negotiation  [ETHERNET,JBP]
	#05 CONSTANT _#opt_status     \ 05 Status                           RFC859 TCP
	#06 CONSTANT _#opt_tm         \ 06 Timing Mark                      RFC860 TCP
\	#07 CONSTANT _#opt_rmt_echo   \ 07 Remote Controlled Trans and Echo RFC726 TCP
\	#08 CONSTANT _#opt_line_width \ 08 Output Line Width                [NIC50005,JBP]
\	#09 CONSTANT _#opt_page_size  \ 09 Output Page Size                 [NIC50005,JBP]
\	#10 CONSTANT _#opt_cr_disp    \ 0A Output CR Disposition            RFC652 TCP
\	#11 CONSTANT _#opt_horz_tab   \ 0B Output Horizontal Tab Stops      RFC653 TCP
\	#12 CONSTANT _#opt_horz_dsip  \ 0C Output Horizontal Tab DispositionRFC654 TCP
\	#13 CONSTANT _#opt_form_disp  \ 0D Output Formfeed Disposition      RFC655 TCP
\	#14 CONSTANT _#opt_vert_tab   \ 0E Output Vertical Tabstops         RFC656 TCP
\	#15 CONSTANT _#opt_vert_disp  \ 0F Output Vertical Tab Disposition  RFC657 TCP
\	#16 CONSTANT _#opr_line_disp  \ 10 Output Linefeed Disposition      RFC657 TCP
\	#17 CONSTANT _#opt_ext_acsii  \ 11 Extended ASCII                   RFC659 TCP
\	#18 CONSTANT _#opt_logoff     \ 12 Logout                           RFC727 TCP
\	#19 CONSTANT _#opt_byte_macro \ 13 Byte Macro                       RFC735 TCP
\	#20 CONSTANT _#opt_date_entry \ 14 Data Entry Terminal              RFC1043 TCP
\	#21 CONSTANT _#opt_supdup     \ 15 SUPDUP                           RFC736 TCP
\	#22 CONSTANT _#opt_supbup_out \ 16 SUPDUP Output                    RFC749 TCP
\	#23 CONSTANT _#opt_snd_loc    \ 17 Send Location                    RFC779 TCP
	#24 CONSTANT _#opt_term_typ   \ 18 Terminal Type                    RFC1091 TCP
	#25 CONSTANT _#opt_eor        \ 19 end of Record                    RFC885 TCP
\	#26 CONSTANT _#opt_tacacs_id  \ 1A TACACS User Identification       RFC927 TCP
\	#27 CONSTANT _#opt_op_mark    \ 1B Output Marking                   RFC933 TCP
\	#28 CONSTANT _#opt_location   \ 1C Terminal Location Number         RFC946 TCP
\	#29 CONSTANT _#opt_3270       \ 1D Telnet 3270 Regime               RFC1041 TCP
\	#30 CONSTANT _#opt_x.3        \ 1E X.3 PAD                          RFC1053 TCP
	#31 CONSTANT _#opt_win_size   \ 1F Negotiate About Window Size      RFC1073 TCP
\	#32 CONSTANT _#opt_term_speed \ 20 Terminal Speed                   RFC1079 TCP
\	#33 CONSTANT _#opt_flow_cnt   \ 21 Remote Flow Control              RFC1373 TCP
	#34 CONSTANT _#opt_linemode   \ 22 Linemode                         RFC1184 TCP
\	#35 CONSTANT _#opt_x_loc      \ 23 X Display Location               RFC1096 TCP
\	#36 CONSTANT _#opt_env_opt    \ 24 Environment Option               RFC1408 TCP
\	#37 CONSTANT _#opt_auth       \ 25 Authentication Option            RFC1409 TCP
\	#38 CONSTANT _#opt_enc1       \ 26 Encryption Option                [DB14]
\	#39 CONSTANT _#opt_enc2       \ 27 New Environment Option           RFC1572 TCP

RFC854 telnet
RFC1116 telnet line mode

 
		#255 CONSTANT _#iac       \ FF
		#254 CONSTANT _#don't     \ FE
		#253 CONSTANT _#do        \ FD
		#252 CONSTANT _#won't     \ FC
		#251 CONSTANT _#will      \ FB
		#250 CONSTANT _#sb        \ 
\		#249 CONSTANT _#ga
\		#248 CONSTANT _#el
\		#247 CONSTANT _#ec
\		#246 CONSTANT _#ayt
\		#245 CONSTANT _#ao
\		#244 CONSTANT _#ip
\		#243 CONSTANT _#brk
\		#242 CONSTANT _#dmark
\		#241 CONSTANT _#nop
		#240 CONSTANT _#se
\		#239 CONSTANT _#eor
\		#238 CONSTANT _#abort
		#237 CONSTANT _#end
		#236 CONSTANT _#table_start_char
null operation [255][0->238]
 
		: _null_operation ( -- false)
			FALSE
		;

This is what linux sends 

 
		: _end ( -- _#end_eof terminator_flag data_flag )
			#end_eof TRUE TRUE
		;
EOR [255][239]

You will find a reference right at the end of RFC885 TCP
Note that if you have not negotiated it's use you should treat the EOR record as a not. Pray tell, why. Why would you send it it it is not a EOR, are the people writing the standard stupid eough to give EOR another meaning. 

 
		: _eor ( -- _#cr terminator_flag data_flag)
			#cr TRUE TRUE
		;
SE [255][240]

This code should not see this, if we do input is not correctly structureed. Damages is done and no purpose is gained by complaining. 

 
		: _se ( --false)
			\ we get here damage has been done
			FALSE
		;
NOP [255][241]

No operation 

 
		: _nop ( -- false)
			FALSE
		;
DMARK [255][242]

Mark the urgent data end. We should not see this as it is the problem of others to read the urgent data up to the mark. 

 
		: _dmark ( --false)
			this :clear
			FALSE
		;
BRK [255][243]

The "break" signal. 

 
		: _brk ( -- false)
			FALSE

		;
BRK [255][244]

Interrupt process. 

 
		: _ip ( -- false )
			FALSE
		;
AO [255][243]

Abort output is not supported 

 
		: _ao ( -- false)
			FALSE
		;
AYT [255][246]

Are you there 

 
		CREATE $patience ," Yes I am"
		: _ayt ( -- false)
			$patience COUNT this :write
			this :flush_file
			FALSE
		;
EC [255][247]

erase character 

 
		: _ec ( --false )
			FALSE
		;
EL [255][248]

erase line 

 
		: _el ( --false)
			FALSE
		;
GA [255][249]

Go ahead 

 
		: _ga ( --false)
			FALSE
		;
SB [255][250]

Start options sub negotiations; read in the data stream until we see [255] [240] 

 

		: _sub_not_used ( options-- false|data flag true)
			DROP
			BEGIN
				_get_data IF
					\ reached end of stream never going to get an answer
					TRUE TRUE
					EXIT
				THEN
				_#iac = IF
					_get_data IF
						\ reached end of stream never going to get an answer
						TRUE TRUE
						EXIT
					THEN
					_#se = IF
						FALSE
						EXIT
					THEN
				THEN
			AGAIN
		;
		\ IAC|SB|NAWS|char_hb|char_lb|line_hb|line_lb|IAC|SE
		\ If the data is IAC it has to be escaped with IAC
		: _sub_naws ( options-- false|data flag true)
			DROP
			\ two bytes of data, we still have to deal with #iac
			zero
			2 0 DO
				8 LSHIFT
				_get_data IF
					\ reached end of stream never going to get an answer
					DROP UNLOOP
					TRUE TRUE
					EXIT
				THEN
				DUP _#iac = IF
					DROP
					_get_data IF
						\ reached end of stream never going to get an answer
						DROP UNLOOP
						TRUE TRUE
						EXIT
					THEN
					DUP _#se = IF
						\ value character(--
						2DROP 
						UNLOOP
						FALSE
						EXIT
					THEN
				THEN
				\ value data(--
				+
			LOOP
			?DUP IF
				1- \ if is the maximum value tab can take so it is zero based
				this :character_max !
			THEN
			zero
			2 0 DO
				8 LSHIFT
				_get_data IF
					\ reached end of stream never going to get an answer
					DROP UNLOOP
					TRUE TRUE
					EXIT
				THEN
				DUP _#iac = IF
					DROP
					_get_data IF
						\ reached end of stream never going to get an answer
						DROP UNLOOP
						TRUE TRUE
						EXIT
					THEN
					DUP _#se = IF
						2DROP 
						UNLOOP
						FALSE
						EXIT
					THEN
				THEN
				\ data
				+
			LOOP
			?DUP IF
				1 - \ max value tab can take so it is zero based
				this :line_max !
			THEN
			\ eat rest of sub option string
			zero _sub_not_used
		;

		\ We request; the server confirms.
		\ IAC|SB|LINEMODE|MODE|mask|IAC|SE
		\ MODE =1
		\	EDIT      bit 0
		\   TRAPSIG   bit 1
		\   MODE_ACK  bit 2 ( acking the mode)
		\   SOFT_TAB  bit 3 ( expend tabs as desired)
		\   LIT_ECHO  bit 4 ( echo control as typed)
		\ If the data is IAC it has to be escaped with IAC
		\ : _sub_linemode ( options-- false|data flag true)
		\	." in sub linemode"
		\	DROP
		\	BEGIN
		\		_get_data IF
		\			\ reached end of stream never going to get an answer
		\			TRUE TRUE
		\			EXIT
		\		THEN
		\		DUP . SPACE
		\		_#iac = IF
		\			_get_data IF
		\				\ reached end of stream never going to get an answer
		\				TRUE TRUE
		\				EXIT
		\			THEN
		\			_#se = IF
		\				FALSE
		\				EXIT
		\			THEN
		\		THEN
		\	AGAIN
		\ ;

		CREATE _sub_vector
			#41 tw,
			' _sub_not_used          t,  \ 00
			' _sub_not_used          t,  \ 01
			' _sub_not_used          t,  \ 02
			' _sub_not_used          t,  \ 03
			' _sub_not_used          t,  \ 04
			' _sub_not_used          t,  \ 05
			' _sub_not_used          t,  \ 06
			' _sub_not_used          t,  \ 07
			' _sub_not_used          t,  \ 08
			' _sub_not_used          t,  \ 09
		
			' _sub_not_used          t,  \ 10
			' _sub_not_used          t,  \ 11
			' _sub_not_used          t,  \ 12
			' _sub_not_used          t,  \ 13
			' _sub_not_used          t,  \ 14
			' _sub_not_used          t,  \ 15
			' _sub_not_used          t,  \ 16
			' _sub_not_used          t,  \ 17
			' _sub_not_used          t,  \ 18
			' _sub_not_used          t,  \ 19

			' _sub_not_used          t,  \ 20
			' _sub_not_used          t,  \ 21
			' _sub_not_used          t,  \ 22
			' _sub_not_used          t,  \ 23
			' _sub_not_used          t,  \ 24
			' _sub_not_used          t,  \ 25
			' _sub_not_used          t,  \ 26
			' _sub_not_used          t,  \ 27
			' _sub_not_used          t,  \ 28
			' _sub_not_used          t,  \ 29

			' _sub_not_used          t,  \ 30
			' _sub_naws              t,  \ 31
			' _sub_not_used          t,  \ 32
			' _sub_not_used          t,  \ 33
			' _sub_not_used          t,  \ 34
			' _sub_not_used          t,  \ 35
			' _sub_not_used          t,  \ 36
			' _sub_not_used          t,  \ 37
			' _sub_not_used          t,  \ 38
			' _sub_not_used          t,  \ 39

			' _sub_not_used          t,  \ 40

		: _sb ( -- false| data flag flag)			
				_get_data IF
					\ reached end of stream never going to get an answer
					TRUE TRUE
					EXIT
				THEN
				\ char
				%%show_telnet_options @ IF
					." server rcvd sub option " DUP . CR
				THEN
				DUP _sub_vector vector
		;
WILL [255][251]

Receiving a WILL, we have to reply with DO or DON'T 

 
		: _send_do { ( option --) }{
			variable %buffer }
			_#iac  %buffer char!
			_#do   %buffer 1 CHARS + char!
			%buffer 2 CHARS + char!
			%buffer 3 this :write
		;


		: _send_don't { ( option --) }{
				variable %buffer }
			_#iac     %buffer char!
			_#don't   %buffer 1 CHARS + char!
			          %buffer 2 CHARS + char!
			%buffer 3 this :write
		;

		: _send_will { ( option --) }{
				variable %buffer }
			_#iac     %buffer char!
			_#will   %buffer 1 CHARS + char!
			          %buffer 2 CHARS + char!
			%buffer 3 this :write
		;

		: _will_don't ( option -- false)
			_send_don't
			FALSE
		;


		\ told it to do so this is my reply
		: _will_suppress_ga ( option -- false)
			DROP
			FALSE
		;
		
		: _will_naws ( option -- false)
			%%naws @ not IF
				TRUE %%naws !
				DUP _send_do
			THEN
			DROP
			FALSE
		;

		: _send_will { ( option --) }{
				variable %buffer }
			_#iac     %buffer char!
			_#will   %buffer 1 CHARS + char!
			          %buffer 2 CHARS + char!
			%buffer 3 this :write
		;

		\ Never ask the other end so what is this about
		: _will_echo ( opt -- false)
			DROP
			FALSE
		;



		\ Described in rfc1184 non implemented in linux
		\ |IAC|SB|LINEMODE|DO|FORWARD_MASK|mask0->8|IEC|SE
		\ FF|FA|22|02|FD|XX|XX|XX|XX|XX|XX|XX|XX|FF|F0
		\ CREATE _eot_start
		\	$FFFA2202 t, $FD00 tw,
		\ CREATE _eot_end
		\ 	$FFF0 tw,
		\ : _send_eot_bitmap { }{
		\	8 CONSTANT _#eot_buffer_length
		\	8 bytes %eot_buffer }
		\	\ fixed data at start of message
		\	_eot_start 5 this :write
		\	%eot_buffer _#eot_buffer_length ERASE
		\	%%eot C@ zero DO
		\		%%eot 1+ I + C@ 8 /MOD  \ rem quot(--
		\		1 ROT 2**               \ quot bit(-- 
		\		OVER %eot_buffer + C@ OR OVER %eot_buffer + C!
		\	LOOP
		\	%eot_buffer _#eot_buffer_length this :write
		\	_eot_end 2 this :write
		\ ;
			
			
			

		
	    \ |IAC|SB|LINEMODE|MODE|mask|IAC|SE|
	    \ 01 = edit = send complete line
	    \ 02 = trapsig = convert contol to NVT caracters; this is most robust.
	    \ 08 = softtab = convert tab to some number of spaces.
	    \ 10 = 
		\ mask = 01 + 02 + 08
		\ FF|FA|22|01|0A|FF|F0
		\ CREATE _linemode_sub 
		\ $FFFA2201 t, 0BFFF000 t, 
		\ : _will_linemode  ( option -- flag)
		\	%%linemode @ not IF
		\		TRUE %%linemode !
		\		_linemode_sub 7 this :write
		\		\ _send_eot_bitmap
		\	THEN
		\	DROP FALSE
		\ ;



		CREATE _will_vector
			#41 tw,
			' _will_don't          t,  \ 00
			' _will_echo           t,  \ 01
			' _will_don't          t,  \ 02
			' _will_suppress_ga    t,  \ 03
			' _will_don't          t,  \ 04
			' _will_don't          t,  \ 05
			' _will_don't          t,  \ 06
			' _will_don't          t,  \ 07
			' _will_don't          t,  \ 08
			' _will_don't          t,  \ 09
		
			' _will_don't          t,  \ 10
			' _will_don't          t,  \ 11
			' _will_don't          t,  \ 12
			' _will_don't          t,  \ 13
			' _will_don't          t,  \ 14
			' _will_don't          t,  \ 15
			' _will_don't          t,  \ 16
			' _will_don't          t,  \ 17
			' _will_don't          t,  \ 18
			' _will_don't          t,  \ 19

			' _will_don't          t,  \ 20
			' _will_don't          t,  \ 21
			' _will_don't          t,  \ 22
			' _will_don't          t,  \ 23
			' _will_don't          t,  \ 24
			' _will_don't          t,  \ 25
			' _will_don't          t,  \ 26
			' _will_don't          t,  \ 27
			' _will_don't          t,  \ 28
			' _will_don't          t,  \ 29

			' _will_don't          t,  \ 30
			' _will_naws           t,  \ 31
			' _will_don't          t,  \ 32
			' _will_don't          t,  \ 33
			' _will_don't          t,  \ 34  linemode
			' _will_don't          t,  \ 35
			' _will_don't          t,  \ 36
			' _will_don't          t,  \ 37
			' _will_don't          t,  \ 38
			' _will_don't          t,  \ 39

			' _will_don't          t,  \ 40

		: _will ( -- false| data flag flag )
			\ get the option
			_get_data IF
				\ terminator
				TRUE TRUE 
				EXIT
			THEN
			%%show_telnet_options @ IF
				." server rcvd WILL " DUP . CR
			THEN
			DUP _will_vector vector
		;
WON'T [255][252]

In a responce to a will we send a won't, if we won't 

 
		\ I didn't issue a do so I have no idea.
		: _won't_?? ( option -- false)
			DROP
			FALSE
		;

		\ I never ask the client to echo my stuff so I should never get this
		: _won't_echo  ( option --false)
			DROP
			FALSE
		;
		
		CREATE _won't_vector
			#41 tw,
			' _won't_??          t,  \ 00
			' _won't_echo        t,  \ 01
			' _won't_??          t,  \ 02
			' _won't_??          t,  \ 03
			' _won't_??          t,  \ 04
			' _won't_??          t,  \ 05
			' _won't_??          t,  \ 06
			' _won't_??          t,  \ 07
			' _won't_??          t,  \ 08
			' _won't_??          t,  \ 09
		
			' _won't_??          t,  \ 10
			' _won't_??          t,  \ 11
			' _won't_??          t,  \ 12
			' _won't_??          t,  \ 13
			' _won't_??          t,  \ 14
			' _won't_??          t,  \ 15
			' _won't_??          t,  \ 16
			' _won't_??          t,  \ 17
			' _won't_??          t,  \ 18
			' _won't_??          t,  \ 19

			' _won't_??          t,  \ 20
			' _won't_??          t,  \ 21
			' _won't_??          t,  \ 22
			' _won't_??          t,  \ 23
			' _won't_??          t,  \ 24
			' _won't_??          t,  \ 25
			' _won't_??          t,  \ 26
			' _won't_??          t,  \ 27
			' _won't_??          t,  \ 28
			' _won't_??          t,  \ 29

			' _won't_??          t,  \ 30
			' _won't_??          t,  \ 31
			' _won't_??          t,  \ 32
			' _won't_??          t,  \ 33
			' _won't_??          t,  \ 34
			' _won't_??          t,  \ 35
			' _won't_??          t,  \ 36
			' _won't_??          t,  \ 37
			' _won't_??          t,  \ 38
			' _won't_??          t,  \ 39

			' _won't_??          t,  \ 40

		\ we have issued a do and got a won't
		: _won't ( --)
			_get_data IF
				\ terminator
				TRUE TRUE EXIT
			THEN
			%%show_telnet_options @ IF
				." server received WON'T " DUP . CR
			THEN
			DUP _won't_vector vector
		;
DO [255][253]

In a responce to a will send a do, if we want and don't if not.

We are receiving. Request by other party to use option ABC. If we set the option we have to respond with will or won't 

 
		: _send_won't { ( option --) }{
				variable %buffer }
			_#iac     %buffer char!
			_#won't   %buffer 1 CHARS + char!
			          %buffer 2 CHARS + char!
			%buffer 3 this :write
		;
		


		: _do_won't ( option --false)
			_send_won't
			FALSE
		;
		
		: _do_will ( option -- false)
			_send_will
			FALSE
		;


		\ it would seem the meaning has changed; won't puts things into line mode.
		\ I want the system in line mode.
		: _do_no_ga ( option -- false)
			DROP 
			FALSE
		;

		\ I sent a will he sent a do; 
		\ In line mode I did it to stop the local echo. If not in line mode I did it so I would echo locally.
		\ characters printed ha ha.
		: _do_echo ( option -- false)
			DROP
			FALSE
		;
		
		CREATE _do_vector
			#41 tw,
			' _do_won't          t,  \ 00
			' _do_echo           t,  \ 01 echo
			' _do_won't          t,  \ 02
			' _do_no_ga          t,  \ 03 If I answer don't linux will go to line mode.
			' _do_won't          t,  \ 04
			' _do_won't          t,  \ 05
			' _do_won't          t,  \ 06 
			' _do_won't          t,  \ 07
			' _do_won't          t,  \ 08
			' _do_won't          t,  \ 09
		
			' _do_won't          t,  \ 10
			' _do_won't          t,  \ 11
			' _do_won't          t,  \ 12
			' _do_won't          t,  \ 13
			' _do_won't          t,  \ 14
			' _do_won't          t,  \ 15
			' _do_won't          t,  \ 16
			' _do_won't          t,  \ 17
			' _do_won't          t,  \ 18
			' _do_won't          t,  \ 19

			' _do_won't          t,  \ 20
			' _do_won't          t,  \ 21
			' _do_won't          t,  \ 22
			' _do_won't          t,  \ 23
			' _do_won't          t,  \ 24
			' _do_won't          t,  \ 25
			' _do_won't          t,  \ 26
			' _do_won't          t,  \ 27
			' _do_won't          t,  \ 28
			' _do_won't          t,  \ 29

			' _do_won't          t,  \ 30
			' _do_won't          t,  \ 31 not a server function, we need to send a do.
			' _do_won't          t,  \ 32
			' _do_won't          t,  \ 33
			' _do_won't          t,  \ 34
			' _do_won't          t,  \ 35
			' _do_won't          t,  \ 36
			' _do_won't          t,  \ 37
			' _do_won't          t,  \ 38
			' _do_won't          t,  \ 39

			' _do_won't          t,  \ 40


		: _do ( -- false| data flag flag )
			_get_data IF
				\ terminator
				TRUE TRUE
				EXIT
			THEN
			%%show_telnet_options @ IF
				." server rcvd DO " DUP . CR
			THEN
			DUP _do_vector vector
		;
DON'T [255][254]

In a responce to a will send a do, if we want and don't if not. 

 
		: _don't_??  ( option -- flag)
			DROP
			FALSE
		;

		\ this is the other end telling me not to echo
		\ after I send a won't
		: _don't_echo ( option --flag)
			DROP
			FALSE
		;

		CREATE _don't_vector
			#41 tw,
			' _don't_??          t,  \ 00
			' _don't_echo        t,  \ 01
			' _don't_??          t,  \ 02
			' _don't_??          t,  \ 03
			' _don't_??          t,  \ 04
			' _don't_??          t,  \ 05
			' _don't_??          t,  \ 06
			' _don't_??          t,  \ 07
			' _don't_??          t,  \ 08
			' _don't_??          t,  \ 09
		
			' _don't_??          t,  \ 10
			' _don't_??          t,  \ 11
			' _don't_??          t,  \ 12
			' _don't_??          t,  \ 13
			' _don't_??          t,  \ 14
			' _don't_??          t,  \ 15
			' _don't_??          t,  \ 16
			' _don't_??          t,  \ 17
			' _don't_??          t,  \ 18
			' _don't_??          t,  \ 19

			' _don't_??          t,  \ 20
			' _don't_??          t,  \ 21
			' _don't_??          t,  \ 22
			' _don't_??          t,  \ 23
			' _don't_??          t,  \ 24
			' _don't_??          t,  \ 25
			' _don't_??          t,  \ 26
			' _don't_??          t,  \ 27
			' _don't_??          t,  \ 28
			' _don't_??          t,  \ 29

			' _don't_??          t,  \ 30
			' _don't_??          t,  \ 31
			' _don't_??          t,  \ 32
			' _don't_??          t,  \ 33
			' _don't_??          t,  \ 34
			' _don't_??          t,  \ 35
			' _don't_??          t,  \ 36
			' _don't_??          t,  \ 37
			' _don't_??          t,  \ 38
			' _don't_??          t,  \ 39

			' _don't_??          t,  \ 40



		\ we have issued a do and got a won't
		: _don't ( --)
			_get_data IF
				\ terminator
				TRUE TRUE EXIT
			THEN
			DUP _don't_vector vector
		;
IAC [255][255]

Dedcode as character 255 

 

		\ #iac #iac --> #iac
		: _iac ( -- char terminator_flag data_flag | false )
			_#iac FALSE TRUE
		;



		CREATE _char_vector_table
			$12 tw, \ number of entries
			' _null_operation t,              \ 0 ->236
			' _end t,                         \ 237
			' _null_operation t,              \ 238
			' _eor t,                         \ 239
			' _se t, ( should never be used)  \ 240  F0
			' _nop t,                         \ 241  F1
			' _dmark t,                       \ 242  F2
			' _brk t,                         \ 243  F3
			' _ip t,                          \ 244  F4
			' _ao t,                          \ 245  F5
			' _ayt t,                         \ 246  F6
			' _ec t,                          \ 247  F7
			' _el t,                          \ 248  F8
			' _ga t,                          \ 249  F9
			' _sb t,                          \ 250  FA
			' _will t,                        \ 251  FB
			' _won't t,                       \ 252  FC
			' _do    t,                       \ 253  FD
			' _don't t,                       \ 254  FE
			' _iac t,                         \ 255  FF

		: _telnet_control ( char -- char terminator_flag data_flag | false )
			DUP _#iac <> IF
				FALSE \ it is not a terminator as we using data already received 
				TRUE 
				EXIT
			THEN
			\ well we have a iac;  
			\ a control character follows drop iac and get control code
			DROP
			\ if we a told it is a terminator the
			\ input stream has finished
			_get_data IF
				\ it was a terminator and it was data
				TRUE TRUE
				EXIT
			THEN
			\ char(--
			_#table_start_char -
			zero MAX
			_char_vector_table vector
		;

		: _store_a_char&echo  { ( addr num char ) variable %len ( --addr num) }
			DUP #lf = IF
				DROP
				EXIT
			THEN
			\ cr-null is sent if user types CR
			DUP not IF
				DROP
				EXIT
			THEN
			\ if not in linemode editing is our problem.
			\ and we have to send the character back
			%%use_line @ not IF 
				DUP #back_space = IF
					DROP
					DUP %len @ <  IF \ > still data to remove
						SWAP 1 CHARS -
						SWAP 1 +
						%%echo_do @ IF
							#back_space EMIT send
						THEN
					THEN
					EXIT
				THEN			 
				%%echo_do @ IF
					DUP BL < not IF  \ >
						DUP EMIT send
					THEN
				THEN
			THEN
			jump char!
			SWAP
			1 CHARS +
			SWAP 
			1 -
		;

		\ as we have to be able to delete characters from the inout stream we have 
		\ to know the length of the input buffer/
		: _read_telnet_stream { ( addr1 num1 ) variable %len ( -- addr2 num2 ) }
			\ if count is one we are in serious trouble and can't store
			\ terminator but don't complain
			BEGIN
				\ addr1 num(--
				\ if the count is one off the termination count
				\ we cannot use it, we have to leave room for the
				\ terminator that indicates we ran out of room.
				\ addr char(--
				_get_data IF
					\ a terminator
					_store_a_char
					EXIT
				THEN
				\ addr num char(--
				DUP eot? 
				%tcp_debug @ IF
					.S send
				THEN
	
				IF
					\ addr num char(--
					_store_a_char
					\ addr num (-- 
					EXIT
				THEN
				\ addr num char(--
				\ if it was control then there is nothing to store
				\ in output stream.
				_telnet_control 
				\ addr num char terminator_flag data_flag | addr num false 
				IF \ we have data
					IF \ it is a terminator
						_store_a_char
						EXIT
					THEN
					\ leave room for terminator
					\ addr num char(--
					%len @ _store_a_char&echo
					DUP 2 < IF    \ >
						\ addr num (--
						DUP IF
							\ if we don't have room don't store
							#end_count _store_a_char
						THEN
						EXIT
					THEN	
				THEN
			AGAIN
		;

		\ at this stage we are aiming to do the echo; user types linemode if this 
		\ is a pain as it will be for a remote logon
		: _inital_options
				\ I want you to send naws
				_#opt_win_size _send_do
				\ I am willing to echo
				\ there is a kluge in the unix telnet client; it decides on the bugs you
				\ have based on the server sending this option. Things seem to go better if
				\ you send something about echo early
				_#opt_echo _send_will
				\ I want you to stop sending the ga
				_#opt_no_ga _send_do
				TRUE %%sent_will !

		;
		
		m:  ( addr len -- len)
			%%sent_will @ not IF
				_inital_options
			THEN
			
			_read_tcp IF
				['] abort_end_task 'abort ! ABORT
			THEN
		; overrides :read

		\ flag is false if all is finished
		\ This read_line is for telnet.
		m:  { ( addr len -- len flag) }{
				variable %len 
				variable %addr }
			\ zero is a problem as we need room to store the terminator
			DUP not IF
				2DROP zero TRUE 
			THEN
			%%sent_will @ not IF
				_inital_options
			THEN
			
			DUP %len !
			OVER %addr !

			\ addr len(--
			%len @ _read_telnet_stream
			\ addr1 len1(--
			NIP %addr @ SWAP
			\ addr len1(--
			%len @ SWAP -
			\ addr len3(--
			this :termination>code
			\ len4 flag(--
			\ close, but even worse destroy task. 
			DUP not IF
				['] abort_end_task 'abort ! ABORT
			THEN
		; overrides :read_line
			
		: _echo_on ( --)
			%%use_line @ IF
				\ we tell remote we won't so it will
				_#opt_echo _send_won't
			THEN
			TRUE %%echo_do !
	
		;

		: _echo_off ( --)
			\ we tell remote we will and then we don't
			\ lying buggers arn't we.
			\ If in character mode the _send_will is not needed.
			_#opt_echo _send_will
			FALSE %%echo_do !
		;

		: _null_control
		;
		
		CREATE control_vectors
			03 tw,
			' _null_control t,
			' _echo_on  t,
			' _echo_off t,
		
		 m: ( code --)
			control_vectors vector
		; overrides :!control

		\ default is server echo; a logged on user can change his session to line mode.
		\ only makes sence if the the cleint supports it; linux does; nt doesn't.
		
		m: ( --)
			TRUE %%use_line !
			\ this puts us into kludge linemode
			\ kludge is well supported.
			_#opt_no_ga _send_won't
			\ and we tell the other end we are no longer echoing
			_#opt_echo _send_won't
		; overrides :linemode


		\ look for the control ^C
		\ Slow I know; but on the good side someone has to type the stuff in
		\ and humans are not going to give us an extreme load.
		\ This code is why the proto task is now responsibe for gettting the input
		\ sequence sorted out.

		0
		| DUP CONSTANT _#nothing_state 1+
		| DUP CONSTANT _#iac_state    1+
		| DUP CONSTANT _#do_state     1+
		| DUP CONSTANT _#sub_state    1+
		| DUP CONSTANT _#sub_iac      1+ 
		DROP

	| : _ti_other ( flag --flag)
	;

	| : _ti_abort ( flag -- true)
		DROP TRUE
	;
	| : _ti_sub ( flag -- flag)
		_#sub_state %%^c_state !
	;

	| : _ti_do ( flag -- flag)
		_#do_state %%^c_state !
	;

	| CREATE _iac_table
		$14 tw,
		' _ti_other t,     \ other
		' _ti_other t,     \ end
		' _ti_abort t,     \ abort
		' _ti_other t,     \ end of record
		' _ti_other t,     \ sub end
		' _ti_other t,     \ nop
		' _ti_other t,     \ datamark
		' _ti_abort t,     \ break
		' _ti_abort t,     \ interrupt process
		' _ti_abort t,     \ abort output
		' _ti_other t,     \ are you there
		' _ti_other t,     \ erase character
		' _ti_other t,     \ erase line
		' _ti_other t,     \ go ahead
		' _ti_sub   t,     \ sub negotiation
		' _ti_do    t,     \ will
		' _ti_do    t,     \ won'T
		' _ti_do    t,     \ do
		' _ti_do    t,     \ don't
		' _ti_other t,     \ iac

		
 		\ flag is true if ^C detected
		| : _nothing_state ( flag char -- flag )
			DUP _#iac = IF
				_#iac_state %%^c_state !
				DROP
				EXIT
			THEN
			#^c = IF
				DROP TRUE 
			THEN
			\ flag(--
		;

		\ first character after an #iac
		| : _iac_state ( flag char -- flag )
	 		_#table_start_char - zero MAX _iac_table vector
	 	;

		\ third charcter in a #iac;#action;code sequence.
	 	| : _do_state ( flag char -- flag)
	 		_#nothing_state %%^c_state !
	 		DROP
	 	;

	 	| : _sub_state ( flag char --flag)
	 		_#iac = IF
	 			_#sub_iac %%^c_state !
	 		THEN
	 	;

		\ look for sub end otherwise be happy
	 	| : _sub_iac  ( flag char --flag)
	 		_#se = IF
	 			_#nothing_state %%^c_state !
	 		THEN
	 	;
	 			
		| CREATE _^c_states 
			5 tw,
			' _nothing_state t,
			' _iac_state  t,
			' _do_state  t,
			' _sub_state t,
			' _sub_iac   t,
			
		\ The idea is this.
		\ The input stream has in effect the main states; normal data and in this
		\ state ^C is ^C; in iac state, in this state other characters have the
		\ same meaning as ^C and ^C can mean something else. And in sub negotiation
		\ in this state ^C means something else. I know this is all a pain but it is needed
		\ if the proto routine is going to set the ^C variable of the telnet task.
			 
		| : _find^C  ( addr num --flag)
			\ num can be zero on a fin
			FALSE -rot
			OVER + SWAP ?DO
					I char@ %%^c_state @ _^c_states vector
			LOOP
		;
		
		m: ( pep --)
			DUP ep_protodata + @ SWAP ep_protocount + @
			_find^C IF
				%%^c @ IF
					TRUE %%^c @ W!
				THEN
			THEN
		; overrides :urgent_data

		m: ( addr num--)
			\ the task that has it's ^c variable set it the last one to
			\ output data.
			user_base activation_^c_set  %%^c !
			DUP IF  \ There is some data
					BEGIN 
						_tcp_data>type_buffer IF \ return true if all ok
							EXIT
						THEN
						\ sent the data to the device to clear the buffer
						this :flush_file
					AGAIN
			ELSE 
				2DROP 
			THEN 
		; overrides :write
	
		m: ( indent --)
			CR DUP SPACES ." tcp_telnet | " ." Object: " this .h 
			CR DUP SPACES 
			              ." lc box  : " %%local_machine @ .h
			              ." rmt box : " %%remote_machine @ .h
			              ." lc port : " %%local_port @ .h
						  ." rmt port: " %%remote_port @ .h

			CR DUP SPACES 
			              ." priority: " %%priority @ .h
			              ." state   : " %%tcp_state @ .h
						  ." snd.una : " %%tcp_snd.una @ .h
						  ." snd.nxt : " %%tcp_snd.nxt @ .h

			CR DUP SPACES
                          ." q sent  : " %%tcp_queue_sent .h
						  ." q unsent: " %%tcp_queue_unsent .h
			              ." snd.end : " %%tcp_snd.end @ .h
						  ." snd.que : " %%tcp_snd.queue @ .h


			CR DUP SPACES 
						  ." rcvqueue: " %%final_receive_queue .h
			              ." rcvpre  : " %%pre_receive_list .h
			              ." rcv.nxt : " %%tcp_rcv.nxt @ .h
                          ." rcv.end : " %%tcp_rcv.end @ .h

			CR DUP SPACES 
			              ." rexmt   : " %%tcp_rexmt @ .h
		                  ." rtt     : " %%tcp_rtt @ .h
		                  ." smooth  : " %%tcp_rtt_smooth @ .h
			              ." rtt_dev : " %%tcp_rtt_dev @ .h
          
			CR DUP SPACES 
			              ." rcv room: " %%final_receive_queue_room @ .h
			              ." rcv.iss : " %%tcp_rcv.iss @ .h
						  ." snd.is  : " %%tcp_snd.is @ .h
						  ." pre room: " %%pre_receive_list_room @ .h
						  ." use line: " %%use_line @ .h
			send
			DROP
		; overrides :print



target_also
&drivers
target_definitions


end_class tcp_telnet

target_previous_definitions
target_previous

: telnet_action  ( handle -- )
	DUP 'output_file !
	DUP 'input_file !
	'abort_file !
	\ advetise
	CR
	.version ."  Telnet server"
	CR
	\ tell the user about linemode
	." If remote type 'linemode' after logon to convert connection to linemode."
	prompt
;

: linemode ( --) 'input_file @ :linemode ;

CREATE $telnet_child ," telnet"

This really is neat, the one gives the number of stack items transfered to the child, this is followed by the word to be executed. A lot better than a UNIX fork. 

 
: start_task  ( client --) 
	one ['] telnet_action #clock_low $telnet_child child_task
;

\ server object address stored here
\ This is only done for debugging
ram_variable %tcp_telnet_server

#clock_low task: telnet_server
	$" tcp_server/#23" 0 $open
	\ change the generated client to a telnet client 
	[ tcp_telnet ]T LITERAL OVER :client! 
	%tcp_telnet_server !
	BEGIN
		%tcp_telnet_server @ :listen
		start_task
	AGAIN
	;task
./version081/tcp/temp.html0100777000000000000000000000115407300314373014261 0ustar rootroot COLDFORTH KERNEL license Stuff that will be defined in good time in correct file 
 

: B@ C@ ; inline
: B! C! ; inline
: hs2net ; inline
: net2hs ; inline
: hs4net ; inline
: net4hs ; inline
2 CONSTANT RTIP_ALEN

: ip@ @ ; inline
: ip! ! ; inline
./version081/tcp/timestamp.html0100777000000000000000000002323607300314373015324 0ustar rootroot COLDFORTH KERNEL

timestamp

license

A user opens a timestamp to use the icmp timestamp protocol. The first two bytes written are the sequence number. They may be very relevent to the ping word, but they are of no interest to the system. If you use it as a two byte ascii number you get 99 id's more than enough.

Unfortunatly there is a os called NT that doesn't support the icmp timestamp message. This will only work with Unix boxes. I have a suspect that the further we go down this path the more useless we will find NT. 

 
io_protocol_common class

		cell% instance_variable %%identifier

				
		\ errors/stats
		cell% instance_variable %%read_errors
		cell% instance_variable %%bad_timestamp_structure

		m: ( parent--)
			this [parent] :construct
			zero %%bad_timestamp_structure !
			zero %%read_errors !
		; overrides :construct

		\ while the port is open we can recieve more peps 
		\ this has to stop before we can proceed.
		: _wait_for_timestamp_close ( identifier --)
			BEGIN
				DUP _timestamp_find DUP not IF
					\ port addr(--
					2DROP
					EXIT
				THEN
				\ port addr(--
				 _#demux_bucket_object + @ this <> IF
					\ someone else has the port now
					\ port(--
					DROP
					EXIT
				THEN
				\ port(--
				xpause
			AGAIN
		;

		m: ( --)
			\ Remove ourselves from the icmp_timestamp_demux table.
			\ We cannot proceed until this is done. If there is a bug 
			\ in the code ( more finds than releases,) we will wait here
			\ forever.
			%%identifier @ _timestamp_remove
			%%identifier @ _wait_for_timestamp_close
			this [parent] :destruct
		; overrides :destruct

		\ string can be /destination_machine
		\               or nothing
		m: ( addr n mode -- instance )
			%%mode !
			\ /machine
			[CHAR] / remove_leading
			\ addr_machine count_machine(--
			DUP IF \ machine specified
				Sresolve_address %%remote_machine !
			ELSE
				2DROP
			THEN
			\ ask the os for a identifier
			\ as soon as we do this we can start receiving 
			\ datagrams destined to the allocated port.
			\ As no one knows about us it is not likely, but it
			\ is possible.
			\ getting the identifer adds it to the demux table
			this _timestamp_identifier %%identifier !
			this
		; overrides :Sopen


		\ protocol says there is a two byte sequence number after
		\ identifer. As far as we are concerned it is part of the
		\ users data area. How the user uses it is his problem. We
		\ are defintily not going to get involved in creating and
		\ tranfering a sequence number.
		: setup_timestamp { ( identifier ) variable %pep -- }{
			ic1_length
			DUP CONSTANT _#org_timestamp 4 +
			DUP CONSTANT _#rev_timestamp 4 +
			DUP CONSTANT _#trans_timestamp 4 +
			DUP CONSTANT _#message_length
			DROP
			}

			_%icmp_object @ %pep @ ep_proto_obj + !

			IPT_ICMP %pep @ [ ep_data ip_proto + ]T LITERAL + B!
					
			%pep @ ep_ipdata + @ ic_seq ERASE

			ICT_TIMERQ	  %pep @ ep_ipdata + @ ic_type + B!
			\ identifier(--
			 %pep @ ep_ipdata + @ ic_id + W!
			ic_seq %pep @ add_to_ip
		;

		m: { variable %pep -- }
			%%local_machine @
			%%remote_machine @ 
			zero
			%pep @ setup_ip
			\ priority can be set as a object variable.
			\ If you ping a COLDFORTH system it has some meaning.
			\ The rest of the internet expects the priority to be zero
			\ in all ICMP messages.
			%%priority @  5 RSHIFT 
			%pep @ [ ep_data ip_tos + ]T LITERAL + B! 
			\ ------------------------------------------
			\ this word sets up a header with no options
			\ if you want options do it yourself.
			\ ------------------------------------------
			\ setup the timestamp header; this does not include the sequence.
			%%identifier @
			%pep @
			setup_timestamp

		; overrides :setup_protocol


		\ the icmp timestamp message shows a little logic there is not an 
		\ additional count
		: _add_to_timestamp ( n pep)
			add_to_ip
		;

An application should call :setup_protocol or :setup_protocol_from_pep

to initialise the pep header. It should then alter header if desired. 

 
		\ as the timestamp server is implemented in icmp_protocol; there is no
		\ need for this method.
		m: ( variable %pep_in variable %pep_out -- )
			TRUE ABORT" :setup_protocol_from_pep not implemenented."
		; overrides :setup_protocol_from_pep 


		: _pep>timestamp_data ( pep -- pep addr n 0 | $)
			DUP ep_ipdata + @
			\ pep addr(--
			OVER ep_ipcount + @ 
			\ pep addr len(--
			ic_seq -
			SWAP 
			ic_seq +
			SWAP
			zero
		;

		\ The big qestion; should We close on an abort or leave it
		\ to the user. The rule is if you take one of these words you can 
		\ convert it into a ior type result with a simple catch. That means
		\ you don't close
		m:  { ( --pep addr n ) }
				%%pep_queue xawait
				%%pep_queue dequeue
				\ pep(--
				DUP ep_error + @ not IF
					_pep>timestamp_data ?DUP IF
						1 %%bad_timestamp_structure +!
						$ABORT
					THEN
					\ pep addr n(--
					EXIT
				THEN
				1 %%read_errors +!
				DUP ep_error + @
				SWAP kill_free_buffer
				$ABORT
		; overrides :read_protocol



		\ the read operation treats each datagram
		\ as a record.
		m:  ( addr len -- len)
			%%active_pep @ not IF
				\ do if for the side effects not the 
				\ stack items
				this :read_protocol 
				%%active_count !
				%%active_pointer !
				%%active_pep !
			THEN
			\ addr len(--
			_read_from_active_pep
			\ len(--
		; overrides :read

		\ write the data pointed to by addr and n to the pep and queue.
		\ we have to write something as the first two bytes are
		\ the sequene number
		CREATE _$default ," 00 hi"
		m: { ( addr n ) variable %pep -- }
			DUP not IF
				2DROP
				_$default
				COUNT
			THEN
			TUCK
			\ n addr n (--
			%pep @ ep_ipdata + @ ic_seq + SWAP MOVE
			\ n(--
			\ have to now fix up ep_len and ip_length
			%pep @ _add_to_timestamp
			%pep @ queue_ip
		; overrides :write_protocol

		\ returns true if data
		m: ( --flag)
			%%active_pep  @ 0= 
			%%pep_queue queue_empty? AND not
		; overrides :key?

		m: ( indent --)
			CR DUP SPACES ." icmp_timestamp | " ." Object: " this .h 
			CR DUP SPACES ." remote machine: " %%remote_machine @ .h 
			CR DUP SPACES ." local machine      : " %%local_machine @ .h
			CR DUP SPACES ." priority           : " %%priority @ .h
			              ." input_pep_queue : " %%pep_queue .h
			CR DUP SPACES ." datagram receives  : " %%datagrams_received @ .h
			              ." discards        : " %%datagram_discards @ .h
			\ indent(--
			CR DUP SPACES ." type buffer        : " %%type_buffer> @ .h
			              ." type count      : " %%type_buffer_count @ .h
			DROP
			send
		; overrides :print

target_also

&drivers
target_definitions

end_class icmp_timestamp

target_previous_definitions
target_previous

	: _receive_timestamp { ( object  ) variable %buffer> ( --  send_time his_time current_time true | false ) }{
			zero
			DUP CONSTANT _#sequence 2 +
			DUP CONSTANT _#org_timestamp 4 +
			DUP CONSTANT _#rev_timestamp 4 +
			DUP CONSTANT _#trans_timestamp 4 +
			DUP CONSTANT _#message_length
			DROP
			}
		%buffer> @ _#message_length ROT :read
		\ count (--
		_#message_length = IF
			\ ### temp
			%buffer> @ _#org_timestamp + @
			%buffer> @ _#trans_timestamp + @
			@standard_ms 
			TRUE
			EXIT			
		THEN
		FALSE 
	;


	\ flag is true if message received
	: _get_timestamp { ( object -- false | send_time his_histime current_time true ) }{
			zero
			DUP CONSTANT _#sequence 2 +
			DUP CONSTANT _#org_timestamp 4 +
			DUP CONSTANT _#rev_timestamp 4 +
			DUP CONSTANT _#trans_timestamp 4 +
			DUP CONSTANT _#message_length
			\ create buffer on stack
			bytes %buffer }
			%buffer _#message_length ERASE
			@standard_ms %buffer _#org_timestamp + !
			%buffer _#message_length jump :write
			DUP :flush_file
			xclock+ @ #10sec + >R
			BEGIN
				xpause
				\ object(--
				^C
				DUP :key?
				IF
					r>drop
					\ object(--
					%buffer _receive_timestamp
					\ false | send_time remote_time current_time true(--
					EXIT
				THEN
				R@ xclock- @ + 
				0> not
			UNTIL 
			r>drop
			DROP
			FALSE
	;


	: $@remote_ticks { ( $  -- remote_ticks TRUE | FALSE ) }{
		$80000000 CONSTANT _#non_standard
		$7FFFFFFF CONSTANT _#time
		#10 CONSTANT _#ms/ticks
		variable %handle
		}
		$" icmp_timestamp/" SWAP  #$buffer get_buffer buffer #$buffer $+ 

		buffer 
		zero $open 
		kill_buffer
		%handle !			
		
		%handle @ 
		\ handle (--
		['] _get_timestamp CATCH IF
			DROP
			%handle @ close
			FALSE
			EXIT
		THEN
		%handle @ close
		IF
			\ success
			\ send_time remote_time recieve_time(--
			OVER _#non_standard AND IF
				2DROP DROP FALSE
				EXIT
			THEN
			_#time AND
			ROT _#time AND - 2/ 
			SWAP +
			_#ms/ticks / 
			TRUE
			EXIT
		THEN
		FALSE
	;

	: @remote_ticks  ( n -- false | ticks true ) 
		\ convert n back to a string
		S>D 
		#$buffer get_buffer 
			buffer #$buffer (d.)
			\ addr n (--
			\ save count at start of string
			SWAP _#$_data - TUCK $count!
			$@remote_ticks
		kill_buffer 
	;


	: @gateway_ticks ( -- ticks true | false)
		0 0 route_get DUP IF
			rt_gw + @ @remote_ticks 
		THEN
	;


	: init_ticks ( --)
		@gateway_ticks IF
			!ticks
		THEN
	;
./version081/tcp/udp_demux.html0100777000000000000000000002207507300314373015313 0ustar rootroot COLDFORTH KERNEL

proto class

license
RFC768

When system starts there has to be a udp object contructed, but only one.

Structure of a UDP datagram 

 
	zero 
	DUP CONSTANT udp_src      2+
	DUP CONSTANT udp_dst      2+
	DUP CONSTANT udp_len      2+
	DUP CONSTANT udp_checksum 2+
	    CONSTANT udp_data

checksum will work as long as all the data is in host order, or all the data is in network order. We do the checksum in host order as the source and destination IP are in HOST order. This means received datagrams have to go throught udp_net<>host before calling this routine 

 
	: udp_checksum_calculation { variable %pep ( --checksum) }{
		variable %ipdata }
		%pep @ ep_ipdata + @ %ipdata !
		zero
		%pep @ [ ep_data ip_src + ]T LITERAL + 
		\ zero addr(--
		\ source and destination address
		DUP [ IP_ALEN 2* ]T LITERAL + SWAP DO
			I W@  +
		2 +LOOP
		\ protocol
		%pep @ [ ep_data ip_proto + ]T LITERAL + C@ +
		\ length
		%ipdata @ udp_len + W@ +
		\ If length is odd pad udp out with zero. Buffers lengths
		\ are always divisible by cell so there is room to place 
		\ the byte
		\ checksum(--
		%ipdata @ udp_len + W@ 
		DUP 01 AND IF
			\ checksum len(--
			zero 					
			OVER %ipdata @ + C!
		THEN
		\ checksum length(--
		%ipdata @ + %ipdata @ DO
			I W@ +
		2 +LOOP
		\ checksum(--
		DUP $10 RSHIFT SWAP $0FFFF AND +
		DUP $10 RSHIFT + 
		-1 XOR
		$0FFFF AND
	;		 
		
	
	\ The last port supplied by the OS.
	ram_variable _%udp_last_port
	\ so the upd object can be found without doing a
	\ _udp_find
	ram_variable _%udp_object

The more lists the faster the demux, the more memory you use. Set as desired. 

 
	$80 CONSTANT _#udp_head_num
	ram_variable _%udp_table _#udp_head_num CELLS ram_allot

_udp_find and _udp_release will be used in the protocol object. _udp_add, _udp_free? and _udp_release will be used in the io_common object for open and close. 

 
	: _udp_find ( local_port remote_ip remote_port --addr|zero)
		_%udp_table _#udp_head_num demux_socket_find
	;

	: _udp_add ( object local_port remote_ip remote_ip_mask remote_port remote_port_mask -- $| addr 0 )
		_%udp_table _#udp_head_num  demux_socket_add
	;

	: _udp_release ( addr --)
		demux_release
	;

	: _udp_free? ( io_object port --)
		_%udp_table _#udp_head_num _demux_socket_free?
	;
	 
 
	\ you use this when you want the os to supply a source port, that
	\ is when you are a client.
	$8000 CONSTANT _#first_udp_system_port
	$10000 CONSTANT _#last_udp_system_port
	\ used to work out wrap around
	_#last_udp_system_port _#first_udp_system_port - 2 / CONSTANT _#udp_range


	: _udp_port { 
			variable %object 
			variable %remote_ip
			variable %remote_ip_mask
			variable %remote_port
			variable %remote_port_mast -- ( record ) }
		_lock_word
		_%udp_last_port @
		_#first_udp_system_port _#last_udp_system_port WITHIN not IF
			_#first_udp_system_port _%udp_last_port !
		THEN
		_unlock_word
		_%udp_last_port @
		\ if two tasks are trying at the same time
		\ one will get in first and the other will keep
		\ going.
		\ port(--
		BEGIN 
			%object @ OVER %remote_ip @ %remote_ip_mask @ 
			%remote_port @ %remote_port_mast @ _udp_add
		WHILE
			1+ 
			DUP _#first_udp_system_port _#last_udp_system_port WITHIN not IF
				DROP _#first_udp_system_port
			THEN
		REPEAT
		\ port record(--
		SWAP
		\ when we store the up to port we must make sure
		\ the task with the highest used port wins. It is a circular number
		_lock_word
		_%udp_last_port @ 2DUP - ABS _#udp_range > IF
			\ wraped around 
			MIN
		ELSE
			MAX
		THEN
		_%udp_last_port !
		_unlock_word
		\ record(--
	;

	 
 

protocol class
		cell% instance_variable %%udp_in_errors
		m: ( --)
			this [parent] :construct
			IPT_UDP   %%protocol_number !
			\ if we return $ we where not added to proto table
			\ and we should not try and remove ourselves.
			this IPT_UDP  proto_add not %%installed !
		; overrides :construct

		\ called if the byte order has to be swaped for network 
		\ transmission. This is done in the interface just prior
		\ to transmission. On reception it is done after the protocol
		\ demux, otherwise we would have to demux twice.
	
		: udp_host<>net  ( ipdata --)
		\	DUP udp_src + W@ hs2net OVER udp_src + W!
		\	DUP udp_dst + W@ hs2net OVER udp_dst + W!
		\	DUP udp_len + W@ hs2net OVER udp_len + W!
		\	DUP udp_checksum + W@ hs2net OVER udp_checksum + W!
		;

		m: ( pep --) 
			DROP
		\   ep_ipdata + @
		\   usp_host<>net
		; overrides :proto_host<>net 


		\ used by the proto task to get rid of the packet.
		m: { ( pep -- ) }{
			variable %ipdata }
			DUP ep_ipdata + @ %ipdata !

			\ the udp protocol has a fixed header
			DUP ep_ipcount + @ udp_data - OVER ep_protocount + !
			%ipdata @ udp_data +  OVER ep_protodata + !




			\ The rules are only checksum if the checksum is non zero.
			%ipdata @ udp_checksum + W@ IF
				DUP udp_checksum_calculation 
				\ checksum calc includes checksum and result should be zero
				IF
					 kill_free_buffer
					 1 %%udp_in_errors +!
					 EXIT
				THEN
			THEN
			\ checksum is good
			%ipdata @ udp_dst + W@
			OVER [ ep_data ip_src + ]T LITERAL + @ 
			%ipdata @ udp_src + W@ 
			\ pep local_port remote_ip remote_port(--
			_udp_find DUP IF
				\ pep table(--
				\ this is a method in io_common
				TUCK _#demux_bucket_object + @ ?DUP IF 
					:consume_port
				ELSE
					kill_free_buffer
				THEN 
				_udp_release
				EXIT
			THEN
			\ pep zero(--
			DROP
			\ the port is unreachable
			\ send a error message and destroy pep
			_#icc_port_unreached SWAP icmp_error_message
		; overrides :proto_demux


		m: { variable %pep -- }{
			variable %ipdata 
			variable %returned_hl }
			%pep @ ep_ipdata + @ %ipdata !
			%ipdata @ ic_data + _ip>ip_hlen
			\ header_length_returend_datagram(--
			%returned_hl !
			%pep @ ep_ipcount + @ ic_data - %returned_hl @ - udp_data < IF \ >
				\ (--
				\ didn't return udp header
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ extracting source port etc.and have a go at queueing packet.
			\ At this stage ep_error is set, this will be seen by the
			\ io_common object and result in a error output.
			\ header_length_returned_datagram(--
			\ remember the datagram is as we sent it
			\ the destination is the remote.
			%ipdata @ ic_data + %returned_hl @ + udp_src + W@
			%ipdata @ ic_data + ip_dst + @
			%ipdata @ ic_data + %returned_hl @ + udp_dst + W@
			_udp_find ?DUP IF
				\ table(--
				\ this is a method in io_common
				%pep @ OVER _#demux_bucket_object + @ ?DUP IF 
					:consume_port 
				ELSE
					kill_free_buffer
				THEN
				_udp_release
				EXIT
			THEN
			\ get here and there is nowhere for error to go
			\ give up
			%pep @ kill_free_buffer
		; overrides :proto_error


		\ UDP requires checksuming
		\ after the source ip address is known.
		\ The source ip address should be determined by 
		\ the interface over which the packet is sent.
		\ Instead of guessing the source ip address we provide
		\ the protocol object and the interface calls :proto_checksun
		\ just before doing the ip checksum, and before converting
		\ the ip header to network order.
		m: { ( pep --) }{
			variable %ipdata }
			DUP ep_ipdata + @ %ipdata !
			zero %ipdata @ udp_checksum + W!
			\ pep(--
			udp_checksum_calculation DUP not IF
				$0FFFF XOR
			THEN
			\ checksum(--
			%ipdata @ udp_checksum + W!
		; overrides :proto_checksum	
		
		\ tell the world about ourselves
		m: ( offset --)
			CR DUP SPACES ." udp_protocol  | " ." Object: " this .h 
			              ." protocol_number: " %%protocol_number @ .h
			              ." installed: " %%installed @ IF
                              ." Yes"
			              ELSE
			                  ." No"
			              THEN
			DROP
			send
		; overrides :print
end_class udp_protocol


	: .udp_demux ( --)
		CR
		." lc port  "
		." users    "
		." object   "
		." rm port  "
		." rm p mk  "
		." rm ip    "
		." rm ip mk "
		." live tm  "
		_%udp_table _#udp_head_num CELLS + _%udp_table DO
			I 
			BEGIN
				@ DUP
			WHILE
				CR
				\ addr(--
				DUP _#demux_local_port + @ .h 
				DUP _#demux_users + @ .h
				DUP _#demux_object + @ .h
				DUP _#demux_remote_port + @ .h
				DUP _#demux_remote_port_mask + @ .h
				DUP _#demux_remote_ip + @ .h
				DUP _#demux_remote_ip_mask + @ .h
				DUP _#demux_live_time + @ .h
			REPEAT
			DROP
		cell +LOOP
	;
./version081/tcp/tcp_server.html0100644000000000000000000004076307300314374015473 0ustar rootroot COLDFORTH KERNEL

the I/O classes for TCP

license
RFC793 TCP
RFC879 TCP
RFC1122 More info
RFC1323 New options
RFC1337 Time wait problem
RFC1185 Time wait
TCP/T
RFC1379 More info
RFC1644 More info
RFC1700 Assigned
telnet server
RFC854 telnet
 


tcp_client class

Head of a linked list of buffers, normally only one present. Can grow quite large if under a syn attack. The timeout routine shrinks it again if the SYN's are not match up be a SYN reply.

tcp_server objects are linked into %syn_timeout_head for the timeout routine. The are linked through %%syn_timeout_link 

 
		ram_variable %syn_timeout_head
		double% instance_variable %%syn_timeout_link

The syn buffers are linked into this head. There is one list per object 

  
		cell% instance_variable %%syn_buffer

This is the number of clients than can be opened but not processed by :listen, to get this far the remote machine must have acked the syn reply we sent.

The server can create differenct client objects. 

 
		cell% instance_variable %%client

		$10 CONSTANT _#client_queue_size
		1 CONSTANT _#client_queue_priorities

		#queue_list_length
		_#transmit_queue_priorities *
		#queue_data_length + bytes% instance_variable %%client_queue 

		m: ( parent--)
			this [parent] :construct
			0 %%syn_buffer !
			_#client_queue_size  _#client_queue_priorities %%client_queue queue_init
			%%syn_timeout_link %syn_timeout_head link_double
			\ the default client created
			[ tcp_client ]T LITERAL %%client !
		; overrides :construct


		: return_syn_buffers ( --)
			%%syn_buffer BEGIN
				DUP @ 
			WHILE
				DUP @ kill_free_buffer
			REPEAT
		;
	

		m:
			%%syn_timeout_link unlink_double
			return_syn_buffers
			this [parent] :destruct
		; overrides :destruct

String can be: 

 
			 /local_port
			 
 
		m: ( addr n mode -- instance )
			%%mode !
			\ addr_port count_port(--
			[CHAR] / remove_leading
			DUP IF \ port speced
				Snumber %%local_port !
			ELSE
				TRUE ABORT" Must supply listen port"
			THEN

			\ Add a tcp demux entry. We are a server we accept
			\ all connections to the port.
			this %%local_port @
			0 0  \ don't care what remove machine 
			0 0  \ don't care what remote port
			\  object local_port remote_ip remote_ip_mask remote_port remote_port_mask (--
			_tcp_add ?DUP IF
				$ABORT
			THEN
			\ a server never times out
			-1 OVER _#demux_live_time + !
			
			%%demux_structure !
		
			\ set the state to listen
			#tcps_listen %%tcp_state !
			\ and that is about it. Your code now has to to listen which
			\ will return open objects connected to particular remote machines
			\ and ports. The creation of the object is done int he proto task.
			this
		; overrides :Sopen
listen

The key to Syn attack protection is to use minimum resources on the initial syn and only commit to the channel if our syn is acked.

The timeout routine ages entries. A buffer in the syn buffer is returned to the free buffer pool when all entries in the buffer have timed out. 

 
		: _remove_syn_entry ( addr --)
			zero SWAP _#listen_inuse + W!
		;

		\ under normal operation you do not need a big buffer. If someone is attacking
		\ then things can grow quite large,
		80 _#sys_buffer_user - CONSTANT _#initial_syn_size

		: _find_empty_syn_entry { -- ( addr ) }
			%%syn_buffer 
			BEGIN
				DUP @ 
			WHILE
				\ link(--
				DUP @ DUP buffer_size _#lhead_data DO
					\ link buffer(--
					DUP I + _#listen_inuse + W@ not IF
						I +
						NIP
						UNLOOP 
						EXIT
					THEN
				_#listen_entry_size +LOOP
				NIP
			REPEAT
			\ link(--
			_#initial_syn_size get_free_buffer 
			DUP DUP buffer_size ERASE
			\ link buffer(--
			TUCK SWAP link_double
			_#lhead_data +
		;


		: _find_syn_entry { variable %remote_machine variable %remote_port -- ( addr true| false ) }
			
			%%syn_buffer 
			
			BEGIN
				DUP @ 
			WHILE
				\ link (--
				DUP @ DUP buffer_size _#lhead_data DO
					\ link buffer(--
					DUP I + _#listen_inuse + W@ IF
						DUP I + _#listen_machine + @ 
						%remote_machine @ 
						=
						OVER I + _#listen_port + W@
						%remote_port @ 
						=
						AND IF
							I + 
							NIP
							TRUE
							UNLOOP 
							EXIT
						THEN
					THEN
				_#listen_entry_size +LOOP
				NIP
			REPEAT
			DROP FALSE
		;



		: _add_syn_entry  { ( machine port service_type seq mss--add) }{
			variable %syn_entry }
			_find_empty_syn_entry %syn_entry !
			\ this must be non zero
			TRUE %syn_entry @ _#listen_inuse + W!
			%syn_entry @ _#listen_mss + W!
			%syn_entry @ _#listen_rcv.iss + !
			%syn_entry @ _#listen_st + W!
			%syn_entry @ _#listen_port + W!
			%syn_entry @ _#listen_machine + !
			initial_sequence %syn_entry @ _#listen_send.iss + !
			xclock+ @ %syn_entry @ _#listen_time + !
			%syn_entry @
		;

		: _listen_mss ( addr -- mss)
			\ if remote machine is on other side of gateway
			\ then mss is set to the internet default
			\ if local mss is dependent on the interface
			DUP _#listen_machine + @ 
			SWAP _#listen_st + W@ $1C AND 2 RSHIFT 
			route_get ?DUP IF
				\ The rules are. Make the receive mss as big as you can 
				\ and tell the other end when you send the sync. The send
				\ mss is the default value unless the other end tells us 
				\ otherwise. The mss depend not only on the connection medium 
				\ but alsp on the host being communicated with. The other end
				\ may not be able to handle a mss greater than the min.
				DUP rt_gw + @ not IF
					\ we are talking locally; make mss dependent
					\ on mtu. This is very important for us as the
					\ rti bus has a mtu of 8k
					\ see rfc876 page 5 for justification for this calculation
					rt_interface + @ :@mtu ip_options - 
					#tcp_header_end - 
					EXIT
				ELSE
					DROP
				THEN
			THEN
			#default_mss
		;
				

		: _send_syn_ack ( addr --) 
			%%remote_machine @
			OVER _#listen_st + W@ $1C AND 2 RSHIFT route_get ?DUP IF
				\ syn_entry route_entry(--
				\ The rules are. Make the receive mss as big as you can 
				\ and tell the other end when you send the sync. The send
				\ mss is the default value unless the other end tells us 
				\ otherwise. The mss depend not only on the connection medium 
				\ but alsp on the host being communicated with. The other end
				\ may not be able to handle a mss greater than the min.
				DUP rt_gw + @ not IF
					\ we are talking locally; make mss dependent
					\ on mtu. This is very important for us as the
					\ rti bus has a mtu of 8k
					\ see rfc876 page 5 for justification for this calculation
					DUP rt_interface + @ :@mtu ip_options - 
					#tcp_header_end - %%tcp_rcv.mss !
				THEN
				DROP
			THEN
			\ syn_entry(--
			DUP _#listen_send.iss + @ \ the sequence number

			\ addr send.iss(--
			#rcv_data_buffer
			\ addr send.iss rcv.wnd(--
			\ add one so I ack remote seq
			ROT _#listen_rcv.iss + @ 1+  \ ack the received syn
			\ send.iss rev.wnd rcv.nxt(--
			#tcpf_ack #tcpf_syn OR 
			_send_empty_segment
		;

Setup the object then link it into the completed object queue this is the queue the :listen method looks at. 

 
		: _setup_tcp_client { ( pep addr  --flag) }{
			variable %new_client }
			\ make sure there are not too many links open
			%%client_queue queue_room? not IF
				2DROP
				FALSE
			THEN
			\ it is not allowed to have a parent if it does 
			\ close tries to deal with it
			zero %%client @ heap_object
			%new_client !
			\ pep table_addr (--
			%new_client @ :client_init
			\ (--
			\ we have to force the queue as we cannot destroy the object
			\ in this code. We are in the proto task. The proto task cannot
			\ be put to sleep for the conveniance of anyone. If you look
			\ at the :destruct code for this object you will see it very
			\ much puts the task executing the word to sleep.
			\ :listen waits for objects to be added to this queue. and returns
			\ them. :listen is executed in the server task. Code that uses listen
			\ will normaly start another task.
			%new_client @ [ %%server_link ]T LITERAL + %%client_queue zero enqueue_force  
			TRUE
		;

Even though the syn reply contains data we do not time it out the person calling for the syn has to time us out. We do this to reduce the trouble syn attacks can cause. the timeout routine times out the table entry and shrinks the table if the number of syn is below an acceptable limit.

The segment contained an ack, all that is valid is a responce from the SEQ and ACK we sent. 

 
		: _ack_seg { variable %pep -- }
			%%remote_machine @ %%remote_port @
			\ source_machine source_port(--
			_find_syn_entry 
			
			IF
				\ addr (--
				\ a syn from this port has been received in the past
				\ Does the new packet ack the sequence we sent in reply
				%pep @ ep_ipdata + @ #tcp_ack + @ OVER _#listen_send.iss + @ 1+ = IF
					\ ok remote acked our seq
					\ clear the table entry we are going onto
					\ bigger and better things
				
					%pep @ OVER 
					_setup_tcp_client IF
						\ success now clients problem
						\ addr(--
						_remove_syn_entry
						EXIT
					THEN
					\ failed; to many clients open
					\ unfortunatly have to reset.
					\ We have to be carefull here the reset has to 
					\ ack the sent syn. If you look at
					\ _send_tcp_reset you will see this has
					\ been dealt with by acking the last sequence in packet.
					\
					\ You might say you left it a bit late.
					\ However others may have left in the 
					\ little time we gained
					\ addr(--
					%pep @ _send_tcp_reset
					%pep @ kill_free_buffer
					EXIT
				THEN
				\ addr(--
				\ ack didn't ack our syn.
				\ send it again.
				\ reset has already been dealt with
				\ addr (--
				DUP _#listen_send.iss + @ 1+ \ the sequence number after the SEQ I send
				\ addr send.iss(--
				#rcv_data_buffer
				\ addr send.iss rcv.wnd(--
				\ add one so I ack remote seq
				ROT _#listen_rcv.iss + @ 1+  \ ack the received syn
				\ send.iss rev.wnd rcv.iss(--
				#tcpf_ack 
				_send_empty_segment
				%pep @ kill_free_buffer
				EXIT		 
			THEN
			\ there was no inital sequence. The remote is speaking bullshit
			\ if a reset drop packet; if anything else send a reset.
			%pep @ _send_tcp_reset
			%pep @ kill_free_buffer
		;

		 
		: _syn_seg { variable %pep -- }
			\ if ack is set as well then we are dealing with
			\ a problem client
			%pep @  ep_ipdata + @ #tcp_flags + B@ #tcpf_ack AND IF
				%pep @ _send_tcp_reset
				%pep @ kill_free_buffer
				EXIT
			THEN
			%%remote_machine @ %%remote_port @
			_find_syn_entry IF
				\ addr(--
				\ its ether the same syn or a bloody mess
				\ this will reply to first syn, lets the other end
				\ decide what to do.
				_send_syn_ack 
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ (--
			\ new syn
			%%remote_machine @
			%%remote_port @
			%pep @ [ ep_data ip_tos + ]T LITERAL + B@
			\ remote_machine remote_port st(--
			%pep @ ep_ipdata + @ #tcp_seq + @

			#default_mss %%tcp_snd.mss !
			%pep @ _process_tcp_options IF
				%pep @ kill_free_buffer
				EXIT
			THEN
			%%tcp_snd.mss @
			_add_syn_entry
			\ addr (--
			_send_syn_ack
			%pep @ kill_free_buffer
		;

If the reset is within the window then clear the syn entry and call everything off. If the reset is outside the window send an ack for the received syn. 

 
		: _reset_seg { variable %pep -- }
			%%remote_machine @ %%remote_port @ 
			\ source_machine destination_machine(--
			 _find_syn_entry IF
				\ addr(--
				\ this is in responce to our SYN ACK
				\ as the ack was set the reset sequence should 
				\ be equal according to standard. We will accept
				\ any responce in window.
				%pep @ ep_ipdata + @ #tcp_ack + @ 
				OVER _#listen_send.iss + @ 
				2DUP = 
				-rot 1+ = OR IF
					_remove_syn_entry
					%pep @ kill_free_buffer
					EXIT
				THEN
				DROP
			THEN
			%pep @ kill_free_buffer
		;
function for each state

The listen state didn't have to implemented in the client. We over ride the entry in the client table. The server only sits in the listen state. The server waits until the we receive a pep that has enought data to put the client in the stablised state and calls :client_init against a new client object to have that happen. So it is the client that runs through new states. The serve just stays in listen. 

 
		: _in_tcps_listen ( pep --)
			DUP [ ep_data ip_dst + ]T LITERAL + @ 
			%%local_machine !
			DUP [ ep_data ip_src + ]T LITERAL + @ 
			%%remote_machine !
			DUP ep_ipdata + @ #tcp_src + W@  
			
			%%remote_port !
			\ pep(--
			DUP ep_ipdata + @ #tcp_flags + B@
			DUP #tcpf_rst AND IF
				DROP 
				_reset_seg
				EXIT
			THEN
			DUP #tcpf_syn AND IF
				DROP 
				_syn_seg
				EXIT
			THEN
			DUP #tcpf_ack AND IF
				DROP 
				_ack_seg
				EXIT
			THEN
			DROP
			\ other it really is a nonsence packet if we get here 
			\ just drop it.
			kill_free_buffer
		;

		' _in_tcps_listen _in_tcp_state_table #tcps_listen  + t!

Transmit task is not used for this state. 

 

		: _out_tcps_listen ( --)
		;

		' _out_tcps_listen _out_tcp_state_table #tcps_listen  + t!

Pretty simple hay. 

 
		m: ( -- obj )
			%%client_queue xawait
			%%client_queue dequeue	
			[ %%server_link ]T LITERAL - 
		; overrides :listen

When we are acking a syn so we are also sending data as the syn is part of the sequence space. We however don't retransmit, it is up to the client to do that if it is serious about getting a connection. 

 
		m: ( --) { -- }{
			variable %entries_used }
			%%syn_buffer 
			BEGIN
				DUP @
			WHILE 
				DUP @
				0 %entries_used !
				\ set true by high level task if it adds an entry to this list
				zero OVER _#lhead_entries_added + !
				\ link buffer(--
				DUP buffer_size _#lhead_data DO
					DUP I + _#listen_inuse + W@ IF
							1 %entries_used +!
							DUP I + _#listen_time + @ _#demux_live_time +  
							xclock- @ + 0< IF   \ >
								\ time to erase
								DUP I + _remove_syn_entry
								-1 %entries_used +!
							THEN
						THEN
				_#listen_entry_size +LOOP
				\ link addr(--
				%entries_used @ not 
				_lock_word
				OVER _#lhead_entries_added + @ not AND IF
					\ this will unlock
					\ link addr(--
					 DUP unlink_double
					 \ added jan 09
					 kill_free_buffer
				ELSE
					_unlock_word
					NIP
				THEN
				\ link(--
			REPEAT
			\ link(--
			DROP
		; method :syn_timeout

		: _syn_timeout ( --)
			%syn_timeout_head
			BEGIN
				@ ?DUP
			WHILE
				DUP [ %%syn_timeout_link  ]T LITERAL - 
				\ link object(--
				:syn_timeout
			REPEAT
		;

Set the client object the server is to create. It is best to base the object on tcp_client, set tcp_telnet fined next. 

 
		m: ( addr --)
			%%client !
		; method :client!

		m: ( indent --)
			CR DUP SPACES ." tcp_server | " ." Object: " this .h 
			CR DUP SPACES ." lc box  : " %%local_machine @ .h
			              ." lc port : " %%local_port @ .h
			CR DUP SPACES ." state   : " %%tcp_state @ .h
			              ." syn_buff: " %%syn_buffer @ .h
			              ." clients : " %%client_queue .h

			send
			DROP
		; overrides :print


target_also
&drivers
target_definitions

end_class tcp_server

target_previous_definitions
target_previous
./version081/tcp/tcp_client.html0100644000000000000000000032125307300314374015437 0ustar rootroot COLDFORTH KERNEL

the I/O classes for TCP

license
RFC793 TCP
RFC879 TCP
RFC1122 More info
RFC1323 New options
RFC1337 Time wait problem
RFC1185 Time wait
TCP/T
RFC1379 More info
RFC1644 More info
RFC1700 Assigned ports

A user opens a tcp_client or tcp_server to use the tcp protocol. 

 
ram_variable %urgent_data

ram_variable %tcp_debug

io_protocol_common class
Tcp timer values in ticks ( 10 msec increments) 
 
		#50          CONSTANT #rexmt_default_value
		#5           CONSTANT #tcp_ack_delay
		#1sec #120 * CONSTANT #time_wait_delay

These we set to whatever we like. This system does not allocate buffers of this size. These determine what we advertize, and how much data we will queue. The data is left in peps until it is presented to the task consuming it. The I/O routines or the task sending the data converts it to peps before we see it. When we send data we copy a pep and send it on it's way. We do not repackage data if other end partly receives a pep. If your communicating with systems that have very small data buffers this will effect performance. This TCP stack is written for embedded systems. Technology being what it is today has made TCP a viable option. In my view it is more important to get good performance in systems with large buffer space. Things have been done to minimise computation and data movement. 

 
		8000 CONSTANT #rcv_data_buffer
		8000 CONSTANT #snd_data_buffer
If we don't get a responce after this many tries, abort the connection 
 
		#8   CONSTANT #abort_retries

If the timeout gets above 20 seconds it really is pretty much a waste of time. If this TCP stack ends up on a Mars probe yes it is too short. Chances of that happening, zero. 

 
		#100 #20 * CONSTANT #max_timeout

Rfc879 page 5, and see RFC 1122 section 4.2.2.6. This is the internets default tcp data size. To get the default tcp datagram size you have to add the tcp header size and ip header size. 

 
		#536 CONSTANT #default_mss

The inital sequence number is to be based on a clock that increments every 4 microsecs. There are 10000 microsecs to a tick. so there are 

 
		#10000 4 /    CONSTANT _#tcp_ticks>ticks

The number of packets that can be placed in each of the tranmit queues. 

 	
		$20          CONSTANT _#transmit_queue_size

The lists are implemented as single list queues. 

 
		1            CONSTANT _#transmit_queue_priorities

The server can create clients the clients thus created are link into here. 

 
			double% instance_variable %%server_link
link into transmit task

We need to talk about this a bit. When we receive a datagram from the remote machine we do not generate a direct reply. This is not an ack nack protocol. When we receive we update the data areas to reflect what has been recieved, and schedule a transmit. If something else has scheduled a transmit earlier then so be it. The tranmit routine will create a packet based on the current receive state.

This links together objects that the transmit task must look at. Exch open tcp link is represented by an object. If an object ins't linked into this list there is no transmit scheduled. The list is maintained in timeout order. The transmit task only deal with the list until it finds objects that havn't timed out. 

 
			double% instance_variable %%transmit_link

When this object wants the transmits to occure. 

 
		cell%   instance_variable %%transmit_time

Set to true if object is in transmit_list 

 
		cell%   instance_variable %%transmit_in_list

%%local_machine and %%remote_machine are defined in io_protocol_common. 

 
		cell% instance_variable %%remote_port
		cell% instance_variable %%local_port

The address of the table created when this io object was added to the demux routine. We don't own it, but we need it's address for the close. 

  
		cell% instance_variable %%demux_structure

If you get a count here ther is an error in this code. 

 
		cell% instance_variable %%tcp_state_error
		cell% instance_variable %%read_error
Round trip time

How long before we retransmit in ticks 

 
		cell% instance_variable %%tcp_rexmt
		cell% instance_variable %%tcp_rtt
		cell% instance_variable %%tcp_rtt_smooth
		cell% instance_variable %%tcp_rtt_dev

The tcb state; see rfc 793. 

 
		cell% instance_variable %%tcp_state

Packets unsent don't have to be dealt with when looking to see if packets have been acked. And unsent packets don't have to be timed out.

If things go as planned the :write_protocol word places the pep into the unsent list. The transmit task takes it out of the unsent list, sends it and places it in the sent list. The proto task accpets incoming datagrams. The incoming datagrams ack data sent. The ack operation results in packets in the sent list being taken out and returned to the free buffer pool.

The other end advertises a maximum window size. This is nice, but only places a limit on what is inflight.

We limit the number of peps that can be queued for transmission. This is done to protect ourselves from excessive data generation. 

 
		#queue_list_length
		_#transmit_queue_priorities *
		#queue_data_length + bytes% instance_variable %%tcp_queue_unsent 
		
		#queue_list_length
		_#transmit_queue_priorities *
		#queue_data_length + bytes% instance_variable %%tcp_queue_sent
pep packets received from other end

Received peps are linked in here in sequence number order. There can still be gaps 

 
		cell% instance_variable %%pre_receive_list

peps in this list reflect the received data only once; and the data is complete. 

 
		#simple_queue_length bytes% instance_variable %%final_receive_queue

The variable is descremented as data added to the pre receive list incremented as data is removed. When it decrements to zero the buffer is about full. Packets that contain the current rcv.nxt sequence number can also be added. 

 
		cell% instance_variable %%pre_receive_list_room
Same for final list. 
 
		cell% instance_variable %%final_receive_queue_room
data areas, inspired by rfc793

The seqence number of incoming datagram effects these areas.

When sending a datagram we use these areas to supply the window and ack value. The ack value reflects the current value of rcv.nxt

Above is now wrong rcv.used has gone

Next seqence to be received. Sequence numbers equal or greater than this have not been received. Sequence numbers less have been received. The syn segment received from the remote machine sets the initial value.

Remember the syn flag occupies one byte of the segment space, as does the fin flag. 

 
		cell% instance_variable %%tcp_rcv.nxt

This is the end we are allowed to advertise up to. There should be a "we have advertised up to variable" as well. As the "can advertise" and "have advertise" occure at different times. Some of the data sent by the other end has to be within the advertised window to be accepted. We use the value contained in this variable, very little is gained by being pedantic. We will accept data past the window as long as the datagram contains some data within the window. 

 
		cell% instance_variable %%tcp_rcv.end
			 
 
		cell% instance_variable %%tcp_rcv.iss
Sending sequences

Initial send sequence; set on open. 

  
		cell% instance_variable %%tcp_snd.is

The highest value ack I have received from other end. Remember this is equal to data seen by other end plus one. Or to put it another way, the sequence number of the packet seen by the other end plus the amount of data contained in the packet. 

 
		cell% instance_variable %%tcp_snd.una

The highest sequence I have sent.plus one, or the first unsent sequence depending on you point of view. Data with sequence numbers less than this will be on the sent queue, data with sequence numbers higher or equal will be on the unsent queue. I get a bit upset if other ends start acking unsent data. 

 
		cell% instance_variable %%tcp_snd.nxt

The ack and window received in the incoming packet has a big effect on these. The last sequence plus one that we may send. This is equal to the ack + ack_window received in the incoming data. 

 
		cell%  instance_variable %%tcp_snd.end

The seqence used to queue data 

 
		cell% instance_variable %%tcp_snd.queue

Congestion window. The end.seq is set by the remote end. Each packet contains a window and this along with the ack value is used to set seq.end

The congestion window is controlled by us. If packets sent arn't acked we conclude the losses were caused by congestion and reduce the congestion window. 

 
		cell% instance_variable %%tcp_snd.congestion.wnd

%%tcp_snd_mss is set to default in construct, and if not told otherwise it is limited to the tcp defualt. %%tcp_snd_mss can be updated by an option in the tcp header received form other end. 

 
		cell% instance_variable %%tcp_snd.mss

The receive segment size is sent by us as an option in the syn message We determine the rcv.mss on object create. It is not altered thereafter. If we are sending to something behind a gateway we set it to a value equal to the tcp default. If we are talking to something on the same network segment we set a value based on the interfaceces maximum transfer unit 

 
		cell% instance_variable %%tcp_rcv.mss

A variable set in the proto task and reset in the transmit task. The proto task sets the variable if an ack is required. The transmit task resets it when a ack has been sent. 

 
		cell% instance_variable %%tcp_send_ack

Type data is collected directoly into the data area of a pep. The base address of the pep has to be kept for transmission. 


		cell% instance_variable %%type_pep

When communication is started the inital seqence number has to be dependent on a clock. 

 
		
		: initial_sequence ( -- num )
			@ticks _#tcp_ticks>ticks * 
			_wreg_TCN1 W@ _#tcp_ticks>ticks _#trr1_value */ + 
		;
			 
 
		m: ( parent --)

	
			this [parent] :construct

			zero %%remote_port !
			zero %%local_port !
			zero %%demux_structure !
			zero %%tcp_state_error !

			\ the timeout variables; we pretend we have had very
			\ stable transmission at the set timeout. 
			#rexmt_default_value %%tcp_rexmt !
			#rexmt_default_value %%tcp_rtt !
			#rexmt_default_value %%tcp_rtt_smooth !
			zero %%tcp_rtt_dev !


			#tcps_closed %%tcp_state !
		
			_#transmit_queue_size  
			_#transmit_queue_priorities 
			%%tcp_queue_sent queue_init
			
			_#transmit_queue_size  
			_#transmit_queue_priorities 
			%%tcp_queue_unsent queue_init	
	

			\ %%transmit_link doesn't have to be initialised
			\ %%transmit_time doesn't have to be initalised
			FALSE %%transmit_in_list !


			zero %%pre_receive_list !

			%%final_receive_queue reset_simple_queue  

			#rcv_data_buffer %%pre_receive_list_room !
			#rcv_data_buffer %%final_receive_queue_room !


			\ when we receive the remote syn this will be set 
			\ to valid value
			zero %%tcp_rcv.nxt !
			#rcv_data_buffer %%tcp_rcv.end ! 


			\ %%tcp_snd.end doesn't have to be initialised
			initial_sequence 

			DUP %%tcp_snd.is !
			
			\ the sync has not been acknowledged.
			DUP %%tcp_snd.una !
			\ skip the SYN value, it will get sent because of the state.
			1+
			DUP %%tcp_snd.nxt !
			DUP %%tcp_snd.queue !
			\ we have received no reply, the window needs to be large enough
			\ to send the syn and that is it
			%%tcp_snd.end !

			\ we start up assumeing link congestion
			#default_mss %%tcp_snd.congestion.wnd !
			
			\ hopefully the incoming syn value will contain an option that
			\ will set this.
			#default_mss %%tcp_snd.mss !
			#default_mss %%type_buffer_size !

			\ we set this and tell other end about it when we send the SYN
			#default_mss %%tcp_rcv.mss !


			\ don't need to start with an ack
			FALSE %%tcp_send_ack !
			
	
		; overrides :construct
support words for trasmit task

The transmit list is a linked list of io objects. They are linked in timeout order.

The receive routine doesn't even try and guess what the transmit routine should send. The receive routine ( which is a proto object executed by the ptroto task) updates the data area and schedules transmit events. The transmit routines determine what is to be sent.

The client task ( the task using the TCP object) queues packets for transmission by the tranmission task, and schedules the transmission task.

tcp opjects that want the tranmission task to look at them link themseleves into the following list. 

 

		ram_variable %tcp_transmit_head

tcp_transmit can only be used within methods. The transmit task is executed every time the tcp level is run, so it has to be pretty efficiant. The list is kept in time sorted order. If the first item has timed out it is removed from the list and the :transmit_action method is executed. :tranmit_action may place the object back in the list. When the :trasmit method is finished the transmit task looks at the list again and sees if the top entry has timed out.

The tcp_transmit_task is ran before the routing task so messages can be on the wire after one pass through the tcp level.

tcp_transmit takes a time. If you set time to xclock+ @ the tcp level will be scheduled directly, and the entry will timeout, this is used for data transmits. If you set time to xclock+ @ 1+ a reschedule will not occure, but the entry will timeout on the next clock interrupt. Ack should be rescheduled in this way. In fact it is probable better to add 5, we allow a pretty big window, and allow 50 msec before a ack is sent. This gives things time to consume data allowing the sending of a ack that better reflect the current window size.

5 is picked as follows

10 Mbits approximatly 1 Mbyte. 1/20 sec = 50k bytes, this will fit in a 64k window. To be working at this speed we are talking on the local net. So responce will be seen almost directly.

On a slow link the delay means very little.

Objects can be added to the transmit list at any level.

Word executed to schedule a transmit event. 

 

		: tcp_transmit ( time --)
			_lock_word
			BEGIN 
				%%transmit_in_list @ IF
					\ if greater
					DUP %%transmit_time @ - 0> IF
						\ new time is greater than old; transmit is scheduled
						\ sooner than new request so drop this one. If you delay acks
						\ by 5, first ack will get scheduled, the rest (  until the ack is
						\ sent)  will pass through here.
						DROP
						_unlock_word
						EXIT
					THEN
					\ this will unlock. We have to unlink as the
					\ list has to be linked in timeout order and we are
					\ about to change the timeout value.
					FALSE %%transmit_in_list !
					%%transmit_link unlink_double
					\ There is a risk that a higher priority task will
					\ link in after we unlink and before we get the 
					\ lock back on, if this happens we just have to 
					\ go around again.
					_lock_word
				THEN
				%%transmit_in_list @ not
			UNTIL
			\ time(--
			\ The lock should be on here
			\ with the object not linked into the transmit list
			DUP %%transmit_time !
			TRUE %%transmit_in_list !
			%tcp_transmit_head
			BEGIN
				\ time link(--
				DUP @
				\ time link link_next(--
			WHILE
				\ time link(--
				2DUP 
				\ time link time link(--
				@ [ %%transmit_time %%transmit_link - ]T LITERAL + @
				\ time link time_new time_old(--
				- 0< IF \ >
					\ next entry is furthur in time so link one back
					\ this word will unlock
					%%transmit_link SWAP link_double
					\ time(--
					xclock- @ + 0< IF  \ >
						\  work is to be done now. This word causes a trap. If we are on 
						\ the lowest level the priority will now be raised and tcp
						\ trasmit and route will do there thing. If we are running
						\ at a high priority this will do no more than schedule the
						\ tcp level for a run when priorities fall.
						run_tcp
					THEN 
					EXIT
				THEN
				@ \ next entry
			REPEAT
			\ time link(--
			\ come to end of list
			%%transmit_link SWAP link_double 
			xclock- @ + 0< IF \ >
				run_tcp
			THEN 
		;

		: _setup_tcp_packet { ( seq rcv.wnd rcv.nxt ) variable %flags variable %pep -- }
			%%local_machine @ %%remote_machine @ 
			zero ( ip_option_length) %pep @ 
			\ seq rcv.wnd rcv.nxt source destination ip_option_count pep(--
			setup_ip
			\ the priority and tos is set to zero. This determines
			\ how %%priority is used. It contains the data encoded as required 
			\ for a direct store into the tcp packet.
			%%priority @ %pep @ [ ep_data ip_tos + ]T LITERAL + B!
			\ seq rcv.wnd rcv.nxt(--
			\ set tcp protocol
			IPT_TCP %pep @ [ ep_data ip_proto + ]T LITERAL  + B!
			#tcp_header_end %pep @ add_to_ip
			%pep @ ep_ipdata + @ 
			\ snd.una rcv.wnd rcv.nxt ip_data(--
			%%local_port @	OVER #tcp_src + W!
			%%remote_port @ OVER #tcp_dst + W!
			SWAP OVER #tcp_ack + !
			\ seq rcv.wnd ip_data(--
			SWAP OVER #tcp_window + W!
			\ seq ip_data(--
			SWAP OVER #tcp_seq + !
			\ ip_data(--
			[ #tcp_header_end 2 RSHIFT ( to 32 bit words) 
			4 LSHIFT ( top 4 bits ) ]T LITERAL
			OVER #tcp_offset + B!
			\ ip_data(--
			%flags @ OVER #tcp_flags + B!
			\ ip_data(--
			zero OVER #tcp_urgptr + W!
			\ ip_data(--
			DUP #tcp_header_end + %pep @ ep_protodata + !
			zero %pep @ ep_protocount + !
			\ the protocol object for checksum latter in the datgrams life.
			_%tcp_object @ %pep @ ep_proto_obj + !
			\ ipdata(--
			DROP
		;

We call this if we want to add the mss to a packet. it is usable with a pep that contains data. The pep has to be long enough to allow us to insert the 4 bytes. If data is present we do have to move it to insert the option. In this implementaton we only send the mss in the syn segment and we do not send data in the syn segment. 

 
		: _set_tcp_option { variable %pep -- }{

					2 CONSTANT #mss_option_code

					\ describe the mss option
					0 
					DUP CONSTANT _#code  1+
					DUP CONSTANT _#len   1+
					DUP CONSTANT _#data  2+ 
					DUP CONSTANT _#opt_length DROP

					#tcp_header_end 4 +  2 RSHIFT ( to 32 bit words) 
					4 LSHIFT ( top 4 bits ) CONSTANT _#header_length 

			}

			\ add_to_ip does not alter the protocol counts and nor should it, 
			\ there are a lot of reasons for adding to the datagram that have 
			\ nothing to do with the protocol
			_#opt_length %pep @ add_to_ip
			%pep @ ep_protodata + @ DUP _#opt_length + %pep @ ep_protocount + @ MOVE
			\ protodata(--
			_#opt_length %pep @ ep_protodata + +! 
			%pep @ ep_ipdata + @
			\ ipdata(--
			_#header_length OVER #tcp_offset + B!
			\ write the option data
			#mss_option_code OVER #tcp_header_end + _#code + B!  
			_#opt_length OVER #tcp_header_end + _#len + B!	
			%%tcp_rcv.mss @ SWAP #tcp_header_end + _#data + W!
			
		;

We create the pep and queue it as an ip. 

 
		: _send_empty_segment { ( seq rcv.wnd rcv.nxt )  variable %flags -- }{
					
				variable %pep 
				
				\ describe the mss option
				0 
				DUP CONSTANT _#code  1+
				DUP CONSTANT _#len   1+
				DUP CONSTANT _#data  2+ 
				DUP CONSTANT _#opt_length DROP
			
				
				
			}
			zero %flags @ #tcpf_syn AND IF
				\ if a syn packet we have to leave room for an option.
				_#opt_length +
			THEN
			[ ep_data ip_options #tcp_header_end + + ]T LITERAL +
			['] get_free_buffer CATCH IF
				\ snd.nxt rcv.wnd rcv.nxt length(--				
				2DROP 2DROP
				EXIT
			THEN
			%pep !
			\ snd.nxt rcv.wnd rcv.nxt(-- 
			%flags @ %pep @ _setup_tcp_packet
			%flags @ #tcpf_syn AND IF
				%pep @ _set_tcp_option
			THEN
			%pep @ queue_ip
		;

		\ if we send a packet out of sequence we should set an ack from the
		\ other end. The other end should discard the packet.
		: _get_responce ( --)
			%%tcp_snd.una @ 1 - \ get a segence number that is out of the window.
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			zero MAX
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_ack _send_empty_segment
		;
		
		: _send_an_ack ( --)
			%%tcp_snd.nxt @ \ next seq to send
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			\ We will accept past end and it can happen
			\ if the sending stack sends the complete segment on spec.
			zero MAX
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_ack _send_empty_segment
		;




		: _return_transmit_queues ( --)
			BEGIN
				%%tcp_queue_sent dequeue ?DUP
			WHILE
				kill_free_buffer
			REPEAT
			
			BEGIN
				%%tcp_queue_unsent dequeue ?DUP
			WHILE
				kill_free_buffer
			REPEAT

		;

		: _return_receive_list ( --)
			BEGIN
				_lock_word
				%%pre_receive_list @ ?DUP
			WHILE
				\ this will unlock
				DUP unlink_double
				kill_free_buffer
			REPEAT 
			_unlock_word
			BEGIN
				%%final_receive_queue simple_empty? not
			WHILE
				%%final_receive_queue #simple_queue_head + @
				%%final_receive_queue simple_deq
				kill_free_buffer
			REPEAT
		;

The time wait state is looked after by tcp_demux. This word sets things up 

 
		: _setup_time_wait ( time --)
			\ amount of time we are to stay in the timewait state
			%%demux_structure @ _#demux_live_time + !
			\ the time we entered the state
			xclock+ @ %%demux_structure @ _#demux_time + !
			\ If we are in this state the object is zero
			0 %%demux_structure @ _#demux_object + !
		;

If you close without doing a flush file; the file will be flushed and the fin flag will get set as part of last packet. It is done this way so short transactions can be done in 5 packets, with the client left in the time wait state. 

			SYN                 client
			SYN ACK             server
			ACK DATA FIN        cleint
			ACK DATA FIN        server
			ACK                 client
			
 
		: _send_fin_packet ( --)
				%%type_buffer> @ IF
					\ still data to be sent
					%%type_buffer> @ 			
					[ #tcp_header_end ]T LITERAL -
					\ tcp_header(--
					#tcp_flags + DUP B@ #tcpf_fin OR SWAP B!
					this :flush_file
				ELSE
					\ queue a fin packet.
					[ ep_data ip_options #tcp_header_end + + ]T LITERAL get_free_buffer
					DUP this :setup_protocol
					\ addr(--
					DUP ep_ipdata + @ #tcp_flags + DUP B@ #tcpf_fin OR SWAP B!
		
					\ addr(--
					0 0 ROT this :write_protocol
				THEN
		;

		: _get_received_packet ( --pep)
			%%final_receive_queue #simple_queue_head + @
			%%final_receive_queue simple_deq
		;
	
		m: ( --)
			\ there is a timer routine to delete TCP demux
			\ entries. We have to have this because the deletion
			\ of the entry has to be delayed if we send the fin first.

			\ If demux structure is set to zero we are closing bacause
			\ of an abort in Sopen
			%%demux_structure @ IF
				zero  \ time to leave the finwait state open
				%%tcp_state @ DUP #tcps_established = 
				SWAP #tcps_synrcvd = OR IF
					#tcps_finwait1 %%tcp_state !
					_send_fin_packet
					\ we don't have to timeout the wait the normal
					\ TCP timeout will do that and send us an abort message
					\ and put us in the abort state
					%%final_receive_queue simple_xawait
					_get_received_packet
					kill_free_buffer
					\ we should now be in the time_wait state
					#time_wait_delay +
				THEN
				%%tcp_state @ #tcps_closewait = IF 
					 \ other end has sent a fin
					 \ we must now send our fin and wait for ack
					#tcps_lastack %%tcp_state !
					_send_fin_packet
					%%final_receive_queue simple_xawait
					_get_received_packet
					kill_free_buffer
				THEN
				\ if we wake here we have received the ack
				\ we can close directly
				\ The time value is how long the demux entry should
				\ servive
				\ time(--
	
				\ we should be in either #tcps_time_wait, #tcps_closed, or listen
				\ but we are not going to look
				\ time(--
				\ if we get here the close has finished from out point of view
				_setup_time_wait
				\ now no more packets will arrive from net
				\ now get us out of the transmit list
				_lock_word
				%%transmit_in_list @ IF
					%%transmit_link unlink_double
				THEN
				_unlock_word
				\ now no more packets will be sent to the net.
				_return_transmit_queues
				_return_receive_list
			THEN
			
			\ We have to remove the type buffer as we have a pointer that points into an 
			\ ip datagram; not the base of a buffer as io_common expects.
			%%type_buffer> @ ?DUP IF
				zero %%type_buffer> !
				%%type_pep @ kill_free_buffer
			THEN			
			this [parent] :destruct
		; overrides :destruct

String can be: 

 
		 /destination_machine/destination_port 
		//destination_port
		or nothing

The mode determines the priority and the type of service required. 

 
		m: ( addr n mode -- instance )
			DUP %%mode !
			\ the mode contains the priority and mode as required
			\ for tcp header
			%%priority !
			\ /machine/port
			[CHAR] / remove_leading
			[CHAR] / left_split 
			\ addr_machine count_machine addr_port count_port(--
			2SWAP DUP IF \ machine specified
				Sresolve_address %%remote_machine !
			ELSE
				2DROP
			THEN
			\ addr_port count_port(--
			[CHAR] / remove_leading
			DUP IF \ port speced
				Snumber %%remote_port !
			ELSE
				2DROP
			THEN
			\ ask the os for a demux entry, this also provides a local port
			\ as soon as we do this we can start receiving 
			\ datagrams destined to the allocated port.
			\ As no one knows about us it is not likely, but it
			\ is possible.
			\ This adds to the udp demux table.
			\ We are a client, we care about detination machine and port
			this 
			%%remote_machine @ -1 
			%%remote_port @ -1
			_tcp_port %%demux_structure !
			%%demux_structure @ _#demux_local_port + @ %%local_port !
			\ find out if remote machine on local net; 
			%%remote_machine @
			\ CE 29 december 2000 @ missing. 
			%%priority @ $1C AND 2 RSHIFT 
			route_get ?DUP IF
				\ The standard calls for this. Needed if multiple interfaces can get you the 
				\ desired result.
				DUP rt_interface + @ :ip @ %%local_machine !
				\ The rules are. Make the receive mss as big as you can 
				\ and tell the other end when you send the sync. The send
				\ mss is the default value unless the other end tells us 
				\ otherwise. The mss depend not only on the connection medium 
				\ but also on the host being communicated with. The other end
				\ may not be able to handle a mss greater than the min.
				DUP rt_gw + @ not IF
					\ we are talking locally; make mss dependent
					\ on mtu. This is very important for us as the
					\ rti bus has a mtu of 8k
					\ see rfc879 page 5 for justification for this calculation
					DUP rt_interface + @ :@mtu ip_options - 
					#tcp_header_end - %%tcp_rcv.mss !
				THEN
				DROP
			THEN
			#tcps_synsend  %%tcp_state !

			\ This adds the object to the transmit list. After this
			\ things are started
			\ the TCP/IP system is trying to get the SYN packet out, and will deal with
			\ the ack received.
			xclock+ @ tcp_transmit
			this

		; overrides :Sopen

Back when the file objects were being written the object :construct word was split from specific action need to open the file, and Sopen was born. Well this came in handy. When a server creates a client it is just creating one of these objects. We need a word to do the action Sopen does based on data received. :client_init is the word.

The SYN buffers contain a head structured as shown below 

 
		zero 
		DUP CONSTANT _#lhead_link_fwd      4+
		DUP CONSTANT _#lhead_linh_back     4+
		DUP CONSTANT _#lhead_entries_added 4+
		DUP CONSTANT _#lhead_data
		DROP

Each syn received creates an entry as described below. The timeout routine deletes entries. 

 
		zero 
		DUP CONSTANT _#listen_inuse       2+
		DUP CONSTANT _#listen_port        2+
		
		DUP CONSTANT _#listen_mss         2+
		\ service type
		DUP CONSTANT _#listen_st          2+
		
		DUP CONSTANT _#listen_machine     4+
		DUP CONSTANT _#listen_time        4+
		\ sequence that came in packet
		DUP CONSTANT _#listen_rcv.iss     4+
		\ sequence that we sent
		DUP CONSTANT _#listen_send.iss    4+
		CONSTANT _#listen_entry_size

addr points to a table contructed as above the pep points to the datagram that can move the client to the established state. We do the movement using the standard receive words because the pep can contain data and a fin flag as well as a syn and a ack of our syn and it is all to complicated to write again. 

 
		ram_variable %tcp_server_error

		CREATE _$bad_open_packet ," Bad open packet"
		m: { variable %pep variable %syn_table (  -- ) }
			%syn_table @ _#listen_machine + @ %%remote_machine !
			%syn_table @ _#listen_port + W@ %%remote_port !

			%pep @ [ ep_data ip_dst + ]T LITERAL + @ %%local_machine !
			%pep @ ep_ipdata + @ #tcp_dst + W@  %%local_port !

			%syn_table @ _#listen_mss + W@ %%tcp_rcv.mss !
			
			\ I received the syn, I expect to see the seqence after the syn
			%syn_table @ _#listen_rcv.iss + @ 
			DUP %%tcp_rcv.iss !

			1+  
			DUP %%tcp_rcv.nxt ! 
			#rcv_data_buffer + %%tcp_rcv.end !
			
			\ I have sent the SYN 
			%syn_table @ _#listen_send.iss + @ 
			DUP %%tcp_snd.is !
			DUP %%tcp_snd.una !
			DUP %pep @ ep_ipdata + @ #tcp_window + W@ + %%tcp_snd.end !

			1+ 
			DUP %%tcp_snd.nxt !
			%%tcp_snd.queue !
			\ Set link to priority and tos requested by client.
			%pep @ [ ep_data ip_tos + ]T LITERAL + B@ %%priority !
			\ set the %%local_machine, it is dependent on the 
			\ address received in the syn datagram, not the
			\ interface the reply is sent.


			
			\ set up the demux entry
			\ we care about all values
			this  %%local_port @ 
			%%remote_machine @ -1 %%remote_port @ -1
			_tcp_add IF
				\ we are in deep shit we can't use the client and we can't close it
				\ The routine that gets the client_object will have to check that this
				\ is non zero. If zero it will have to close it directly.
				zero %%demux_structure !
				%pep @ kill_free_buffer
				EXIT
			THEN
			%%demux_structure !

			#tcps_synrcvd %%tcp_state !
			\ so the packet gets used twice, the server object
			\ deals with the packet and creates a client object
			\ the client object is put into the state in which
			\ this packet is expected and it uses the packet again.
			\ If you look at the client code it can deal with stange 
			\ combinations of ack data and fin,
			%pep @  this :consume_port
			%%tcp_state @ #tcps_synrcvd @ > not IF
				\ if the state is not above #tcps_synrcvd then
				\ we have to close the link down again.
				\ This should not happen!
				1 %tcp_server_error +!
				_$bad_open_packet ep_data get_free_buffer this :abort_connection
			THEN
			\ well that is it folks.
		; overrides :client_init



		: _add_to_tcp ( n  pep  -- ) 
			2DUP add_to_ip
			ep_protocount + +!
		;
			

		\ 
		\ 
		m: { variable %pep -- }
			\ don't set the ack bit cause it is not a valid ack unless
			\ the ack and window fields are updated
			%%tcp_snd.queue @ 0 0 #tcpf_ack %pep @ _setup_tcp_packet
		; overrides :setup_protocol

		\ not a valid ooption
		m: ( %pep_in %pep_out -- )
			TRUE ABORT" Not a valid option"
		; overrides :setup_protocol_from_pep

The big qestion; should We close on an abort or leave it to the user. The rule is if you take one of these words you can convert it into a ior type result with a simple catch. That means you don't close 

 
		\ you send a fin after closing; so no use trying in FIN_WAIT_1
		\ We have to receive all packets in CLOSE_WAIT.
		\ An aggressive sender can send data in the SYN_SENT and
		\ SYN_RCVD state.
		\
		: _bad_receive_state? ( -- flag )
			\ deal with common case as directly as possible
			%%tcp_state @ #tcps_established = IF
				FALSE
				EXIT
			THEN

			\ less common
			%%tcp_state @ 

			DUP #tcps_synsend = IF
				DROP FALSE
				EXIT
			THEN

			DUP #tcps_synrcvd = IF
				DROP FALSE
				EXIT
			THEN

			\ closewait receive up to message that is a string
			\ return 0 0 0 for the string
			DUP #tcps_closewait = IF
				DROP FALSE
				EXIT
			THEN
			
			\ abort queues a pep that is supposed to be read.
			#tcps_abort = IF
				FALSE
				EXIT
			THEN
			TRUE
		;

		\ the room in the final list effects the window.
		\ Room in the pre list simple determines how many out of order packets
		\ we will receive. The pre list belongs to the protocol. It allows us to
		\ deal with out of order and duplicate reception; that is all.
		\
		\ The idea is; if the current receive possition and the room left in the final queue
		\ is greater than the current end position plus the room needed to receive a message then
		\ move the end. This gets executed as data is removed from the receive queue so it has
		\ to be workable from differnt tasks priorities.
		\
		: _update_rcv_window ( --)
			_lock_word
			%%tcp_rcv.nxt @ %%final_receive_queue_room @ + DUP 
			%%tcp_rcv.end @ %%tcp_rcv.mss @ +
			- 0> IF
				%%tcp_rcv.end !
			ELSE 
				DROP
			THEN
			_unlock_word
		;

		\ I don't care what anyone says; this turned out really neat.
		m:  { ( --pep addr n ) }{ variable %pep }
			\ the protocol has many states from which you can't receive data
			_bad_receive_state? IF
				0 0 0 
				EXIT
			THEN
			\ if we want to timeout the reception we have to wait for a 
			\ packet using a different method.
			%%timeout @ not IF
				%%final_receive_queue simple_xawait
			ELSE
				%%timeout @ %%final_receive_queue simple_xawait?
				xtimeout? IF
					0 0 0 
					EXIT
				THEN
			THEN

			\ if we get to here there is a pep queued to be used
			\ as we please.
			_get_received_packet

			\ pep(--
			\ we have to do this first as system queues peps 
			\ that have nothing more than an ep_error value
			DUP ep_error + @ IF
				%%tcp_state @ #tcps_abort = IF
					panic" tcp connection aborting : "
					\ ICMP messages ????? make sure they get to here
					DUP ep_error + @ COUNT panic
				THEN
				kill_free_buffer
				0 0 0
				EXIT
			THEN
			\ we have to increase %%final_receving_queue_room, if the available 
			\ room is now bigger than mss we send an ack to tell the other end
			\ the window is now open, a winder advertisment.
			%%final_receive_queue_room @
			\ pep old (--
			_lock_word
			OVER ep_protocount + @ %%final_receive_queue_room +!
			_unlock_word	
			_update_rcv_window
			\ pep old(--
			%%tcp_rcv.mss @ < IF  \ >
				\ window was closed may open
				%%final_receive_queue_room @ %%tcp_rcv.mss @ < not IF \ >
					\ window can now be opened.
					\ should we send ack directly or should we queue.
					\ If we queue............
					\ If data is being sent in the
					\ other direction then this will only alter the time.
					\ If the link is quite then it is an additional overhead.

					\ TRUE %%tcp_send_ack !
					\ xclock+ @ tcp_transmit		

					\ If we ack directly.............
					\ The software load is less. If data is being sent then it
					\ is an extra packet. I don't know, neither is the better choice.

					_send_an_ack

				THEN
			THEN
			DUP ep_protodata + @
			OVER ep_protocount + @
		; overrides :read_protocol
		
		: _read_active ( --)
			%%active_pep @ ?DUP IF
				0 %%active_pep !
				kill_free_buffer
			THEN
			this :read_protocol
			%%active_count !
			%%active_pointer !
			%%active_pep !
		;

As we read in data we increase addr and decrease num. Our aim here is speed. This only gets the data from the active pep. 

 
		: _read_binary_stream ( addr1 num1 -- addr2 num2 flag)
			%%active_count @ 
			OVER < not IF  \ >
				\ addr1 num1(--
				\ the data request can be satisfied with data over
				2DUP %%active_pointer @ -rot MOVE
				\ addr num (--
				DUP NEGATE %%active_count +!
				DUP %%active_pointer +!
				+ zero
				\ can be end of stream all the data isn't read from the pep 
				FALSE
				EXIT
			THEN
			\ move what we have in pep
			\ if the fin flag is set well 
			\ this is just all you are going to get
			\ addr1 count(--
			%%active_pointer @ jump %%active_count @ MOVE
			%%active_count @ -
			\ addr1 stil_to_get(--
			SWAP %%active_count @ + SWAP
			\ addr2 still_to_get(--
			%%active_pep @
			\ addr still_to_get pep(--
			zero %%active_pep !
			zero %%active_count !
			DUP ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
				TRUE
			ELSE
				FALSE
			THEN
			SWAP kill_free_buffer
		;

		\ flag is true if channel closing
		: _read_tcp  { ( addr len -- len flag) }{
				variable %len }
			DUP %len !
			BEGIN
				\ go in circles until
				\ we have requested data
				\ or until closed by other end
				\ remember read assumes no data structure
				\ we will return with the count
				\ unless channel is closed in which case
				\ we return with less than count
				%%active_count @ not IF
					\ get a new pep
					_read_active
					%%active_pep @ not IF
						\ timeout was set and we timed out
						\ or the connection has clossed
						NIP
						%len @ SWAP - _bad_receive_state? IF
							TRUE
						ELSE
							FALSE
						THEN 
						EXIT
					THEN
				THEN
				\ addr len(--
				_read_binary_stream
				\ addr len flag(--
				\ if flag is true stream is finished 
				IF
					NIP
					%len @ SWAP -
					TRUE
					EXIT
				THEN
				\ else num should be zero
				DUP not IF
					2DROP %len @
					FALSE
					EXIT
				THEN
			AGAIN
		;

		\ if len comes up too short stream is finished.

		m:  ( addr len -- len)
			_read_tcp
			\ len flag(--
			\ The flag is true if the connections is to close.
			\ I don't know what to do; the device is now invalid
			\ Best to sabort I think
			ABORT" Device has closed"
		; overrides :read


		: eot?  ( char -- flag )		
			%%eot #$count_length + %%eot $count@ zero DO
			\ char addr (--
			2DUP char@ = IF
				2DROP
				TRUE
				UNLOOP
				EXIT
			THEN
			1 CHARS +
			LOOP \ char addr(--
			2DROP
			FALSE
		;

A termination code has to be stored at the end of the input. Num2 will never equal num1. This differs from ANSI forth, if we followed the standard the user would have to make the buffer 1 ( the standard requires two) characters longer that num1. I think that is absolute nonsence designed to cause programming bugs. 

 
		: _get_a_character ( -- char)
			%%active_pointer @ char@
			1 CHARS %%active_pointer +!
			[ 1 CHARS NEGATE ]T LITERAL %%active_count +!
		; 
		
		: _store_a_char ( addr num char --addr num)
			DUP #lf = IF
				DROP
				EXIT
			THEN
			jump char!
			SWAP
			1 CHARS +
			SWAP 
			1 -
		;

		: _unget_character ( char --)
			DROP
			1 CHARS %%active_count +!
			[ 1 CHARS NEGATE ]T LITERAL %%active_pointer +!

		;
			 
			1) slow as a wet wig as each character has to be looked at.
			2) Assumptions are made on character set and size.

And lets be honest about this, these have to be the same as the assumtions made by unix if you are going to get involved in the internet. 

 
			1) slow as a wet wig as each character has to be looked at.
			2) Assumptions are made on character set and size.
			3) telnet assumptions made

Flag is true if the data stream is finished. 

 
		: _get_data ( -- term true | char false)
			%%active_count @ not IF
				\ look at the fin flag for the last pep.
				%%active_pep @ IF
					\ addr pep(--
					%%active_pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
						\ addr pep(--
						%%active_pep @ kill_free_buffer
						0 %%active_pep !
						\ addr(--
						#end_eof TRUE
						EXIT
					THEN
				THEN
				\ have to get more data into buffer
				_read_active 
				%%active_pep @ not IF
					\ if we returned without a pep we are finished
					#end_eof TRUE
					EXIT
				THEN
			THEN
			_get_a_character 
			FALSE
		;


		: _read_terminal_stream { ( addr1 num1 -- addr2 num2 ) }{
			}
			BEGIN
				\ addr1 num(--
				\ if the count is one of the termination count
				\ we cannot use it, we have to leave room for the
				\ terminator that indicates we ran out of room.
				\ addr num(--
				_get_data IF
					\ a terminator
					_store_a_char
					EXIT
				THEN
				\ addr num char(--
				DUP eot? 
				IF
					\ addr num char(--
					_store_a_char
					\ addr num (-- 
					EXIT
				THEN
				\ addr num char(--
				_store_a_char
				\ leave room for terminator
				OVER 2 < IF \ >
					\ addr num (--
					DUP IF
						#end_count _store_a_char
					THEN
					EXIT
				THEN	
	
			AGAIN
		;




		m:  { ( addr len -- len flag) }{
				variable %len 
				variable %addr }

			\ zero is a problem as we need room to store the terminator
			DUP not IF
				2DROP zero TRUE 
			THEN

			DUP %len !
			OVER %addr !

			\ addr len(--
			_read_terminal_stream
			\ addr1 len1(--
			NIP %addr @ SWAP
			\ addr len1(--
			%len @ SWAP - 
			\ addr len3(--
			this :termination>code
			\ len4 flag(--
		; overrides :read_line

		

		m: ( addr num --num flag)
			2DUP 1- + char@ 
			\ driver specific
			#end_eof = IF
				NIP 1- FALSE
				EXIT
			THEN
			\ addr num --num flag
			this %%terminal @ ::termination>code
		; overrides :termination>code

Write the data pointed to by addr and n to the pep and queue. Queued data is only sent from four states. 

			SYN-SENT
			SYN-RECEIVED
			ESTABLISHED
			and CLOSE-WAIT

If you queue in other states the queue will become full and you will sleep forever. It is probable best to abort if we are not in a valid state. 

 
		: _bad_send_state? ( --flag)
			\ most common
			%%tcp_state @ #tcps_established = IF
				FALSE EXIT 
			THEN
			\ occures if other end has closed and
			\ is waiting for us to stop yaddering
			%%tcp_state @ DUP #tcps_closewait = IF
				DROP FALSE EXIT 
			THEN
			\ getting in a bit fast. Opening hasn't finished.
			\ However queueing data is acceptable.
			DUP #tcps_synsend = IF
				DROP FALSE EXIT 
			THEN
			DUP #tcps_synrcvd = IF
				DROP FALSE EXIT 
			THEN
			\ so we can send the fin
			DUP #tcps_finwait1 = IF
				DROP FALSE EXIT
			THEN
			\ se we can send the fin
			#tcps_lastack = IF
				FALSE EXIT
			THEN
			TRUE
		;

Write the data into the pep and queue the pep for transmisison. It is assumed that the pep has been properly set up. 

 
		m: { ( addr n) variable %pep ( --) }
			_bad_send_state? IF 
				'output_file @ this = IF
					\ be happy
					%pep @ kill_free_buffer
					2DROP
					EXIT
				ELSE
					TRUE ABORT" Can't transmit data with link in this state"
				THEN
			THEN 
			\ add_to_ip can deal with zero.
			\ add n (--			
			DUP %pep @ _add_to_tcp
			\ MOVE can deal with a zero count
			\ and common destination and source address
			%pep @ ep_ipdata + @ #tcp_header_end + SWAP MOVE
			\ we now have to get the end sequence from the pep
			\ as the fin flag may be set.
			%pep @ _end_sequence 1+
			\ seq(--
			%pep @ %%tcp_queue_unsent zero
			\ address queue_head prority(--
			\ this gets the data onto the queue.
			enqueue_wait
			\ seq (--
			%%tcp_snd.queue !
			\ We need to transmit directly
			\ even if there is already data in the trasmit queue we may be able
			\ to send the new data directly as there can be more than one packet 
			\ in flight.
			xclock+ @ tcp_transmit		

		; overrides :write_protocol

Write buffered data to storage if you follow write through you will find our buffer is the pep and there is no need to transfer the data. If you look at the definition of MOVE you will see it is bright enough not to move data that has a common source and destination address. 

 
		m:  \ compile time ( --xt)
			\ runtime ( --)
			%%type_buffer> @ ?DUP IF 
				zero %%type_buffer> !
				%%type_buffer_count @ %%type_pep @ this :write_protocol
				zero %%type_buffer_count !
			THEN
			
		; overrides :flush_file

Keep going around until count is zero, each time around we send a little more data. 

 
		: _tcp_data>type_buffer ( addr count -- false|addr count true)
			%%type_buffer> @ not IF
				%%type_buffer_size @ 
				[ ep_data ip_options #tcp_header_end + + ]T LITERAL + get_free_buffer
				DUP this :setup_protocol
				DUP %%type_pep !
				ep_ipdata + @ #tcp_header_end +
				%%type_buffer> !
				zero %%type_buffer_count !
			THEN
			\ addr count(--	
			%%type_buffer_size @ %%type_buffer_count @ - 
			\ addr num left(--
			2DUP > IF ( will not all fit)
				\ addr count amount_to_fit(--
				\ make sure we have a type buffer
				>R \ addr count (--
				OVER %%type_buffer> @  %%type_buffer_count @ + R@ MOVE \ put in as much as we can
				\ addr count(--
				SWAP R@ + SWAP R@ -   \ update send data to reflect what has been sent
				\ addr_new count_new(--
				R> %%type_buffer_count +!
				FALSE                  \ tell :write to send the packet
				                       \ and come back again
				EXIT
			THEN
			\ data will fit in the buffer
			DROP
			\ character we are up to since last record ( eol ).
			%%type_buffer> @  %%type_buffer_count @ + SWAP \ addr to count(--
			\ update %%type_buffer_count after you have done the address calculations
			DUP %%type_buffer_count +!
			MOVE
			TRUE
		;

		m: ( addr num--)
			DUP IF  \ There is some data
					BEGIN 
						_tcp_data>type_buffer IF \ return true if all ok
							EXIT
						THEN
						\ sent the data to the device to clear the buffer
						this :flush_file
					AGAIN
			ELSE 
				2DROP 
			THEN 
		; overrides :write

If the final_receive_queue has data then this should return true. The data could be a string returned fron the proto task. 

 
		m: ( --flag)
			%%final_receive_queue simple_empty? not
		; overrides :key?

Urgent data only has a meaning if the tcp client type assigns it a meaning. The following method is called in the proto task if the urgent bit is set.

The task does not see urgent data. It would seem the urgent data option has been so badly broken that it is not even used to interrupt the process. It's obvious use. 

 
		m: ( pep --)
			DROP
		; method :urgent_data

Support functions for TCP

Tcp options

None of the RFC1323 options are handled. However this code must be able to scan across these options and ignore them.

If we return true the pep will go. Only set if the option list is badly structured 

 

		: _tcp_fault_option ( option -- byte_after flag)
			TRUE
		;

		: _tcp_unknown_option { ( option -- byte_after flag) }{
				zero 
				DUP CONSTANT _#code  1+
				DUP CONSTANT _#len   1+ 
				DUP CONSTANT _#opt_head DROP
			}
			DUP _#len + B@ 
			\ addr len(--
			DUP _#opt_head < IF \ >
				\ option count doesn't even cover header
				\ we are dealing with rubbish
				+ TRUE 
				EXIT
			THEN
			+
			FALSE
		;

The option does nothing other than take up one byte position 

 
		: _tcp_align ( addr -- addr flag )
			1+ FALSE
		;


		: _tcp_mss { ( addr -- addr flag ) }{
				0 
				DUP CONSTANT _#code  1+
				DUP CONSTANT _#len   1+
				DUP CONSTANT _#data  2+ 
				DUP CONSTANT _#opt_length DROP
			}

			DUP _#len + B@ _#opt_length = IF
				\ option is well constructed
				DUP _#data + unalignedW@ 
				DUP %%tcp_snd.mss !
				\ set the type buffer size to the mss size
				%%type_buffer_size !
				_#opt_length + FALSE
				EXIT
			THEN
			\ it is not well structured.
			\ fail the packet
			DUP _#len + B@ + TRUE
		;

		CREATE _tcp_option_vectors 
			$04 tw,                   \ number of entries
			' _tcp_fault_option t,    \ 0 does not get processed here, just something to put in table
			' _tcp_align t,           \ 1 align
			' _tcp_mss t,			  \ maximum segment size.
			' _tcp_unknown_option t,  \ this and higher options are not supported

The option field is a byte. 

 
		: _tcp_process_an_option ( addr_opt -- addr_after flag )
			  DUP B@  _tcp_option_vectors vector
		;

Unknown options are simply ignored. 

 
		: _process_tcp_options { variable %pep -- ( flag ) }{
			variable %options_end
			}
			\ this is the common route , no options
			\ do as little as possible.
			%pep @ ep_protodata + @
			%pep @ ep_ipdata + @ -
			#tcp_header_end = IF
				FALSE
				EXIT
			THEN 

			\ if we get here we have options
			%pep @ ep_protodata + @ %options_end !
			%pep @ ep_ipdata + @ #tcp_header_end +
			\ option_pointer(--
			BEGIN
				\ end of option list code is a zero option
				DUP B@ not IF
					DROP
					FALSE	
					EXIT
				THEN
				\ list has finished
				DUP %options_end @  < not IF \ >
					DROP
					FALSE
					EXIT
				THEN
				( opt_addr (-- new_option_addr FLAG )
				_tcp_process_an_option IF
					\ bad bad option
					DROP
					TRUE
					EXIT
				THEN
				DUP %options_end @ > IF
					\ if here structure of option list is rubbish
					DROP
					TRUE
					EXIT
				THEN
			AGAIN	
		;

In send window

We are talking about the outgoing packets seqence number here. In the beginning the send window is dependent on the ack and window received in incoming datagrams. 

			SEQ.NXT <= SEG.SEQ+SEG.LEN-1 
			and 
			SEG.SEQ <= RCV.END

This test will transmit one packet past the end of the window. It has one super dooper big advantage. The zero window code folds into the timeout code. I can't see why it won't work, but there must be some problem as all the implementations I have looked at pretend a zero window is some special thing. We will see. 

 
		:   _in_send_window { variable %pep ( -- flag ) }{ 
				variable %send_end }

			\ number of bytes unsent
			\ %%tcp_snd.end is only increased by packet steps.
			%%tcp_snd.end @ %%tcp_snd.nxt @ - 
			zero MAX
			%%tcp_snd.congestion.wnd @ MIN
			%%tcp_snd.nxt @ + %send_end !

			\ the end is not allowed to preceed %%tcp_snd.una
			\ but this is a null test as packets that meet this
			\ condition are no longer in the transmit list
			\ %pep @ ep_end_seq + @ %%tcp_snd.una @ - 0< IF
			\	DROP FALSE EXIT
			\ THEN
			\ 
			\ The start is not allowed to be past %send_end
			%pep @ ep_start_seq + @  %send_end @ - 0> IF
				FALSE
				EXIT
			THEN

			TRUE
		;

The tranmission task only schedules a timeout if there is data to be sent. Remember the task that takes packets from this list is on the same level as us so we don't have to lock between testing for an emty queue and using the data in teh queue. 

 
		: _schedule_timeout ( --)
			%%tcp_queue_sent find_queue_list ?DUP IF
				%%tcp_rexmt @ 
				\ The timeout is dependent on the timeout time 
				\ of the first packet in queue, if it has been sent.
				\ And the first item in the queue should have been sent.
				\ list time(--
				SWAP #queue_list_head + @ 
				ep_tcp_xclock + @  + 
				\ time(--
				\ but we do not schedule a timeout on this tick, we have 
				\ to remember the round trip time can be less than 1 tick.
				DUP xclock+ @ 2 + - 0< IF
					DROP
					xclock+ @ 2 +
				THEN
				tcp_transmit		
			THEN
		;
transmit

The transmit task doesn't get involved in packaging the data. TCP supports urgent data but the urgent data is part of the tcp sequence. Once you have commited the data to a particular seqence you have to stick with it, otherwise you add complications to the protocol. You have to start asking, can I alter the seqence now. You may be tempted to say, you know the other machine is up to you have a ack to tell you. The reply tells us where the machine was up to when it sent the reply. It could now be well past what we are going to resend. What set of data will the machine use. What we sequenced first or what we are about to resequence. Nope once the data is committed to a send, it's order must remain fixed.

So we have data that has been packaged by smarter routines than us, they have added the urgent data if required. There is a further anvantage in doing it this way. Routines that want speed can put there data into peps and use lower level routines to add the transmit packets onto this list. Thus avoiding a data movement.

If the other end has moved snd.una to a point partway through a packet ( whick is likely if the other end is having buffer problem, we do not modify the packet. It would take time as not only do we have to remove the unneeded data, we ould have to update the urgent pointer. Special conditions tests take time and introduce bugs, best not to do.

The flag field is used to set the tcp headers flag field. If the syn bit is set the option field is included.

flag is true if data sent.

This work out really really well. I like it.

A lot of things just happen.
Data exist in the list from snd.una to whatever has been queued by the task. If the task is waiting for queue space, the code that removes the data from the queue will wake the task when such an action happens. It's up to the When a packet timesouts and needs tranmission there can be many inflight. The first non ack doubles the timeout and retransmits the guilty packet. The window congestion window is also reduced. However if the limit is the amount of data available for transmission, this has little effect. More time has to pass before other packets are trasmitted. 

 

	: _clone_datagram { variable %pep (  -- pep2) }{
			variable %buffer
			}
		%pep @  ep_len + @ 
		\ length(--
		['] get_free_buffer CATCH IF
			\ we can simple pretend it didn't happen
			\ and things will sort themseleves out
			DROP
			zero
			EXIT
		THEN
			
		%buffer !
		\ copy data into transmit pep
		\ (--
		%pep @ %buffer @ %pep @ ep_len + @ MOVE
			
		\ update ep_ipdata
		%pep @ ep_ipdata + @ %pep @ -
		%buffer @ + %buffer @ ep_ipdata + !

		\ update protodata
		%pep @ ep_protodata + @ %pep @ -
		%buffer @ + %buffer @ ep_protodata + !	
		%buffer @	
	;

		: _tcp_send_pep_contents { variable %pep }{

			variable %buffer

			}

			%pep @ _clone_datagram %buffer !
													
			\ updates the ack and window. Note we don't alter the packet. 
			\ The flags are set when the packet is queued. This means we
			\ send the syn without data. But so what
			\ we are trying to write a TCP driver that
			\ interoperates not push the standard to it's limit.

			%buffer @ ep_ipdata + @
			%%tcp_rcv.nxt @ OVER #tcp_ack + !
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - SWAP #tcp_window + W!

			%buffer @ queue_ip
		;

		: _tcp_send_contents { variable %pep -- }
			\ see comments below
			xclock+ @ %pep @ ep_tcp_xclock + !
			%%tcp_snd.end @ %%tcp_snd.una @ - 0> not IF
				\ we are sending into a zero window.
				\ If an ack is required, send only ack, as you
				\ cannot piggy back data in this situation and be assured the
				\ ack will get accepted. A real protocol suff up I think; but that is
				\ the way it is. The problem is the rules on page 26 of RFC793.
				\ If no ack is required send the data. It is nothing more than a probe
				\ and it may as well be a probe that can move things forward,
				\ things can change while the packet is inflight.
				\
				\ Remember the window open can be lost
				\ so you have to probe every now and again.
				\ The probe can be the next valid packet. The other end
				\ will just drop it if window is still zero. As there is no
				\ data to be acked, who cares.

				\ I should add that this test brings little to the table. If data
				\ is coming in the other direction most of the acks will be acks.
				\ This probe, if it always contained data would be nothing more than
				\ a lost ack occuring every now and again.

				\ This is a valid state, we should not increment
				\ ep_tcp_tries. However if we do this we can end up with TCP 
				\ connections left open forever. It would occure as follows.
				\ 1) Remote machines closes window.
				\ 2) Remote machine dies.
				\ But that is just the way it is.
				%%tcp_send_ack @ IF
					EXIT
				THEN
			ELSE
				1 %pep @ ep_tcp_tries + +!
			THEN
			FALSE %%tcp_send_ack !
			%pep @ _tcp_send_pep_contents	
		;

Trace down the sent queue and send timed out packets the trace down has finished when we arrive at untimed out packet. We have a small problem, we can't simple take the packet out of the list and send, we have to clone it. We can not get away from this. TCP requires one data copy. The IP stack as written is based on two principles. 1) we don't care how the packet was generated and 2) if the code cannot deal with the packet it can destoy it. We are only allowed to destoy transmit data if the other end has acked it. 

 
		CREATE _$timeout_trans ," To many transmit retries"
		: _try_and_send_data ( -- )
			%%tcp_queue_sent find_queue_list ?DUP IF
				#queue_list_head +
				BEGIN
					\ if the entry is zero we don't test time
					\ and we finish the loop
					@ DUP DUP IF
						ep_tcp_xclock + @ xclock- @ + 
						%%tcp_rexmt @ + 0< 
					THEN
				WHILE
					\ list (--
					\ if the number of reties is too great we abort the connection
					DUP ep_tcp_tries + @ #abort_retries > IF
						DROP
						_$timeout_trans
						ep_data get_free_buffer
						this :abort_connection
						EXIT
					THEN
					\ pep(--
					\ remember the congestion window reduction can take what was in
					\ the send window out of the window. We should take note of this. 
					\ If this occures data should be sent as the congestion 
					\ can never be reduced below one packet.
					DUP _in_send_window not IF
						\ there is no need to look at the unsent queue it will definitly be
						\ outside the window.
						DROP
						EXIT
					THEN
					\ is the packet still in the window. Remember every packet retransmitted 
					\ reduces the congestion window. 

					\ pep(--
					DUP _tcp_send_contents
					\ The standard requires us to reduce the congestion window by
					\ half.
					\ 
					\ list(--
					%%tcp_snd.congestion.wnd @
					1 RSHIFT
					\ don't reduce below the maximum segment.
					%%tcp_snd.mss @ MAX
					%%tcp_snd.congestion.wnd !				
					
					\ and double the retransmit time
					%%tcp_rexmt @ 1 LSHIFT 
					\ the is a maximum timeout
					#max_timeout MIN
					%%tcp_rexmt !
				REPEAT
				DROP
			THEN
			\ now we have to deal with unsent data
			BEGIN
				%%tcp_queue_unsent 
				find_queue_list ?DUP
			WHILE
				#queue_list_head + @ 
				DUP _in_send_window not IF
					DROP
					EXIT
				THEN
				\ we have to try and queue the data on the sent queue
				\ if we fail it has to remain on the unsent.
				\ Too much data is inflight
				\ pep(--
				%%tcp_queue_sent zero enqueue_try IF
					\ couldn't queue on the sent queue
					\ too many packets inflight.
					EXIT
				THEN
				\ (--
				%%tcp_queue_unsent dequeue
				\ pep(--
				DUP _tcp_send_contents
				ep_end_seq + @ 1+ %%tcp_snd.nxt !
			REPEAT
		;

Look to see if ack can be piggy backed on data. If not send empty ack packet. 

 
		: _send_data ( --)
			\ if we sent something the ack is in the head
			_try_and_send_data 
			%%tcp_send_ack @ IF
				FALSE %%tcp_send_ack !
				_send_an_ack			
			THEN
			_schedule_timeout
		;

This is only called if datagram is only transmitted once. 

 
		: _update_round_trip  { ( time -- ) }{
			\ values taken from comer volume 1 edition 3
			3 CONSTANT #rtt_gain_asr
			2 CONSTANT #rtt_dev_asr
			3 CONSTANT #dev_gain
			}
			\ the round trip time is done in 10 msec inc, it can be zero
			\ if less than 10 msec, just round up by 1. 
			1+
			DUP %%tcp_rtt @  -
			\ time diff(-- 
			DUP #rtt_gain_asr >>a
			%%tcp_rtt @ + %%tcp_rtt_smooth !
			\ time diff(--
			SWAP %%tcp_rtt !
			\ diff(--
			ABS %%tcp_rtt_dev @ - 
			#rtt_dev_asr >>a 
			%%tcp_rtt_dev @ + 
			%%tcp_rtt_dev !
			%%tcp_rtt_smooth @ %%tcp_rtt_dev @ #dev_gain * + 
			%%tcp_rexmt !
		;

Incoming data, link it into receive list.

While TCP presents itself to the application as a byte stream, at the low level this system deals in peps. :read_protocol fetches the next pep. This word deals with overlapping data, and removes urgent data from the input stream. 

 

		: _link_tcp_pep { ( link) variable %pep -- ( flag ) }	
			\ link(--
			\ to be linked after this	
			%pep @ SWAP link_double	
			\ we don't include the seq and fin flag in the queue room calculations.
			\ queue room is only used to protect us from attack
			%pep @ ep_protocount + @ NEGATE 
			\ this belongs to the proto task
			%%pre_receive_list_room +!
		;


		\ packets received get put on pre. They are transfered to final up to the first hole in the
		\ data stream. 
		\ The output flag is true if the fin flag was found when transfering data to final.
		: _pre>final { -- ( flag ) }{
				variable %in_rcv.nxt 
				variable %fin_flag 
			}
			%%tcp_rcv.nxt @ %in_rcv.nxt !
			FALSE %fin_flag !
			\ Only send an ack if rcv.nxt moves forward.
			\ If it doesn't packet is out of order and ack will be wasted.
			\ Fast recovery requires an ack every time a packet is received
			\ out of order. We don't support it.

			\ This may be the key packet and we can now move forward multiple packets
			\ (--
			BEGIN
				 %%pre_receive_list @
			WHILE
		
				\ if the beginning of the segment is less or equal to  rcv.nxt
				\ then the end can become rcv.nxt. The packet has to be removed
				\ from the %%pre_receive_list. If it adds to the data stream
				\ it is moved to the %%final_receive_queue. The data pointers 
				\ in the packet are updated so the data reflects the data steam even though
				\ it is still spead across multiple peps. 
				\ When the data is transfered to final the :urgent_data function is called.
				\ The :urgent_data function see's the full data stream after reconstruction
				\ with the header fields still intact.
				%%pre_receive_list @ ep_start_seq + @  
				%%tcp_rcv.nxt @ 
				- 0> not IF \ start is less or equal next
					%%tcp_rcv.nxt @ %%pre_receive_list @ ep_start_seq + @ - \ number to skip 
					DUP %%pre_receive_list @ ep_protodata + +! 
					\ This can give a negative result if it is there is no relevent data in the packet.
					NEGATE %%pre_receive_list @ ep_protocount + +!
					
					\ update nxt
					%%pre_receive_list @ ep_end_seq + @ 1+ 
					%%tcp_rcv.nxt @ MAX
					%%tcp_rcv.nxt !

					\ remove packet from pre.
					%%pre_receive_list @ DUP unlink_double
					\ pep(--
					
					DUP ep_protocount + @ 0> IF 
						\ pep contains new data
						\ urgent data is ran in the proto task so things like ^C do something.
						\ It may use the urgent data pointer if it is used properly. Telnet
						\ doesn't come close. The Telnet driver scans the data because the urgent data
						\ pointer is so bady broken. All has to do with a spec stuff up folowed by a BSD stuff
						\ up. You know history.
						
						DUP this :urgent_data

						DUP ep_protocount + @ NEGATE %%final_receive_queue_room +!
						DUP %%final_receive_queue

						simple_enq
						\ On transfer to final we look at the fin flag.
						\ We need to know this before the task because it is a protocol thing.
						ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
							TRUE %fin_flag !
						THEN
					ELSE
						\ can have no data and a fin flag.
						DUP ep_protocount + @ 0= IF
							DUP ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND IF
								TRUE %fin_flag !
							THEN
						THEN
						\ repeat of old; just get rid of the pep.
						kill_free_buffer
					THEN
				ELSE
					
					\ packet is out of sequence. No use to continue
					_update_rcv_window
					%%tcp_rcv.nxt @ %in_rcv.nxt @ <> IF
						TRUE %%tcp_send_ack !
						xclock+ @ #tcp_ack_delay + tcp_transmit
					THEN
					%fin_flag @
					EXIT
				THEN
			REPEAT
			\ no packets left in pre receive queue 
			_update_rcv_window
			%%tcp_rcv.nxt @ %in_rcv.nxt @ <> IF
				TRUE %%tcp_send_ack !
				xclock+ @ #tcp_ack_delay + tcp_transmit
			THEN
			%fin_flag @
			;

Packet sequence is checked before entering this it is acceptable if in is greater or equal to %tcp_rcv.nxt and within our window range. We only check that the packet seqence is in the window range this means that the amount of data present can be greater than the receive window. But so what. This code will ever queue the packet on the recieve_list or get rid of it.

Flag is true if fin processed. If the incoming packet contains a fin the data may not be finished. Remember packets can come out of order rcv.next has to have move up to the packet.

This code is responsible for initiating the ack. The ack is initated by setting %%tcp_send_ack and consuming the packet.

Because we are responsible for sending the ack we have to sort the packets into order.

We are allowed to queue packets past %%tcp_rcv.end. We are not allowed to ack them.

Duplicate packets will be queued. They will be returned when the data is read. 

 
		: _queue_tcp_pep { variable %pep -- }{
				variable %incoming_seq
			}

			\ set incoming start
			%pep @ ep_start_seq + @ %incoming_seq !
			\ ok we have to add to data structure
			\ if the %incoming end is not greater than rcv.next then it is a duplicate packet no longer
			\ in window.
			\ Deplicate packets are rejected by the sequence check done very early in
			\ the piece.
			%%pre_receive_list BEGIN
				DUP @
			WHILE
				\ if the seq of the next packet in the list is greater then the
				\ sequence of this then this is the link spot
				DUP @ ep_start_seq + @ 
				\ compare the next sequence  ( the ends) 
				%incoming_seq @ - 0< not IF  \ >
					\ link(--
					%pep @ _link_tcp_pep
					\ (--
					EXIT
				THEN
				@
			REPEAT
			\ link(--
			\ if we get here we have reached end of this
			\ link the packet in at the end
			%pep @ _link_tcp_pep
		;

		\ the pre packet list is full we have to drop one. We go for the last in the list. Remeber packets
		\ are linked in sequence order the last is the least interesting.
		: _drop_pre_packet ( --)
			%%pre_receive_list BEGIN
				DUP @ 
			WHILE
				@
			REPEAT
			DUP ep_protocount + @ %%pre_receive_list_room +!
			DUP unlink_double
			kill_free_buffer
		;

If the packet contains no data and no fin flag it is irrelevent to this code. We only acks stuff we have been sent. Or in other words you do not ack an ack. The SYN is dealt with as a seperate issue. 

 
		: _receive_tcp_pep { variable %pep -- ( fin_flag ) }
			%pep @ ep_protocount + @ zero = 
			%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin AND not 
			AND IF
				%pep @ kill_free_buffer
				\ definitly no fin flag.
				FALSE
				EXIT
			THEN

			\ place in sequence order; decrement the amount of room in the list.
			%pep @ _queue_tcp_pep

			\ move packets that are ready to be from pre to final; that all data that has no
			\ holes in the sequence. If packets are received in order the packet wil go onto
			\ the pre list and then transfered directry to the fina list.
			
			_pre>final \ fin_flag(--

			\ if there is no room left in the pre list drop most appropiate packet until there is.
			\ As all packets need not be of same length this may involve droping more than one packet.
			\ This will ony occure if a packet missing and a lot of data was inflight.
			BEGIN  
				%%pre_receive_list_room @ 0< \ > 
			WHILE 
				_drop_pre_packet
			REPEAT
	
		;

The %%tcp_queue contains unacked packets. Before this code is called one must check that the ack is acceptable, this deals with wild packets. We can then assume we are dealing with rational data. Trace down the queue and remove packets whose end comes before the new ack value. Remember the ack value is what is expected next. The queue is in seqence number order. If a test fails the job is done.

The ack can ack multiple packets. The RTT is a measure of how long it takes to get a packet acked. Not how long it takes the packet to get to the computer, and the ack to get back. Unfortunatly we have this thing called "ack delay". On short hops this is the most critical issue. This stack delays by #tcp_ack_delay as an example. We therefor need to use the send time of the first packet in the group acked. 

 
		: _tcp_acked { variable %pep -- }{
				variable %update_trip
			}

			\ remember ack is next seq expected
			FALSE %update_trip !

			\ move the window forward. Remember there can be multiple acks 
			\ with the same seqence number and we can receive them out of order.
			\ Only update if this ack moves things forward.
			%pep @ ep_ipdata + @ #tcp_ack + @ DUP 
			%%tcp_snd.una @ 
			- 0> IF
				%%tcp_snd.una !
			ELSE
				\ and if it doesn't move things forward then we are finished
				\ with this
				DROP
				EXIT
			THEN

			%%tcp_snd.una @ %pep @ ep_ipdata + @ #tcp_window + W@ + 
			DUP %%tcp_snd.end @ - 0> IF
				%%tcp_snd.end !
			ELSE 
				DROP
			THEN
			\ just because ack looked correct we should not assume
			\ we have data in list, anything is possible.
			\ (--
			\ Remove those packets that have now been acked.			 
			\ The queue has only one list; but no matter.
			BEGIN
				\ (--
				%%tcp_queue_sent
				find_queue_list 
				?DUP not IF
					\ nothing more in list
					EXIT
				THEN
				\ list (--
				DUP #queue_list_head + @ 
				ep_end_seq + @
				\ list last_seq(-- 
				%%tcp_snd.una @ - 0<  \ >
			WHILE
				\ list (--
				remove_list
				1 %%tcp_queue_sent #queue_limit + +! 
				\  packet(-- 
				DUP ep_tcp_tries + @ 1 = IF
					\ packet has only been sent once 
					\ this is an unambiguous ack.
					%update_trip @ not IF 
						TRUE %update_trip !
						DUP ep_tcp_xclock +  @ NEGATE xclock+ @ +
						\ packet round_trip_time(--
						 _update_round_trip
					THEN
				THEN
				kill_free_buffer
			REPEAT
			DROP
		;

snd.una <= seg.ack <= snd.nxt The ack is the next byte expected. or in words the ack can be equal to the last ack and can be equal or less than the last byte sent. Remeber the ack gives the next byre to be received. 

 
		: _ack_acceptable? ( pep -- flag ) 
			ep_ipdata + @ #tcp_ack + @ DUP %%tcp_snd.una @ - 0< IF
				DROP FALSE EXIT
			THEN
			%%tcp_snd.nxt @ - 0> IF
				FALSE EXIT
			THEN
			TRUE
		;

We process the ack even if the ack value equals %%tcp_snd.una as the ack may contain a window update, and _tcp_acked looks after the window.

On error: (SEG.ACK < SND.UNA), it can be ignored. If the ACK acks something not yet sent (SEG.ACK > SND.NXT) then send an ACK, drop the segment, and return. 

 
		: _process_ack { variable %pep -- }
			%pep @ _ack_acceptable? IF
			    \ (--
				\ we get here all is ok
				\ remove packets that have been acked.
				%pep @ _tcp_acked
			ELSE
				%pep @ ep_ipdata + @ #tcp_ack + @  
				%%tcp_snd.nxt @ - 0> IF
				    \ ack is for data not sent.
					TRUE %%tcp_send_ack !
				THEN
			THEN
		;

			 
			RCV.WND = 0 SEQ.SEQ = RCV.NXT
			or
			RCV.NXT =< SEQ.SEQ < RCV.END 
			or 
			RCV.NXT =< SEG.SEQ+SEG.LEN-1 < RCV.END

The last two reduce to: 

			RCV.NXT <= SEG.SEQ + ( SEG.LEN-1 ZERO MAX)
			and 
			SEG.SEQ < RCV.END

If I allow the reception of data up to RCV.END I will accept one packet after the window has been set to zero. Big deal, I just have to make sure I don't ack past RCV.END that is likely to send some stacks to the moon. It will also mean no special handling has to occure for a zero window. If all stacks where written like this the zero window probe and the ack contained therein could be in the next packet to be sent. If I use a sandard packet for the zero probe then the probe ack will not be accepted by a stack written to the standard. As the zero window probe does not occure often it would not be a big problem. I am tempted.

There is the question of urgent data. I think there should be a clear boundry between the protocol and the applicaiton. Once you commit to a sequence thats is it your committted. This stack is written that way.

This sysem will discard a packet if the sequence numbers are within a range already received. It will not check for a difference. And if there is a difference pray tell which is right. The answer definitly isn't " the last one received".

Anyway, allow one byte past the end and the test reduces to: 

			RCV.NXT <= SEG.SEQ + ( SEG.LEN-1 ZERO MAX ) 
			and 
			SEG.SEQ <= RCV.END

This is called in all states that can receive data. This routine sets the fields ep_start_seq and ep_end_seq. these can then be used to deccide what to do with hte packet. 

 

		: _seq_acceptable? { variable  %pep  -- ( flag ) }{ 
				variable %incoming_start 
				variable %incoming_end }
			%pep @ ep_ipdata + @ #tcp_seq + @ DUP %incoming_start !
			DUP %pep @ ep_start_seq + !
			
			%pep @ _end_sequence 
			
			\ start end(--
			\ If no data the end is before, for this test that is
			\ not what we want 
			2DUP - 0> IF
				DROP
			ELSE
				NIP
			THEN
			%incoming_end !
			\ (--
			\ the end is not allowed to preceed %%tcp_rcv.nxt
			%incoming_end @ %%tcp_rcv.nxt @ - 0< IF \ >
				FALSE EXIT
			THEN
			\ the start has to proceed or be equal to %%tcp_rcv.end 
			\ using the start allows us to receive past the window
			\ as we only test that the first byte in the packet is within.
			\ the window. See discussion above. This is not in accordance with
			\ standard.
			%%tcp_rcv.end @ %incoming_start @ - 0<  IF \ >
				FALSE EXIT
			THEN
			TRUE
		;

If flag is true we have disposed of packet. If false the packet is. This can only be used if we have other ends sunc value. Because all packets have to past this test we have to set seq to snd.end after we have sent our fin and it is acknowledged. So when we have finished sending data and the fact has been acked by other end, the acks for packets received form other end will have a seg one past the fin flag seqence, and the fin flag will not be set.

Even though we have the other ends syn value we do not use this test in syn received. In that state it is posible to have an outstanding syn ack packet that could move us to established. This packet would not be accepted if we used this test. 

 
		: _packet_out_of_window { variable  %pep -- ( flag ) }
			%pep @ _seq_acceptable? not IF
				\ if not check reset
				%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_rst AND IF
					%pep @ kill_free_buffer
					TRUE
					EXIT
				THEN
				\ else send an ack
				%pep @ kill_free_buffer
				TRUE %%tcp_send_ack !
				TRUE
				EXIT
			THEN
			FALSE 
		;

The state code

The in are executed within the proto task, the outs are executed within the transmit task

Open in both directions. This has to come before the syn states because it can be called from these states. 

 
		CREATE _$syn/rst1 ," Syn or Rst packet received in established state"
		CREATE _$connection_closed ," Connection closed"
		CREATE _$connection_closing ," Connection closing"


		
		\ sometimes you only want to return string to the receiving task.
		: _return_string  ( string pep --)
			TUCK ep_error + !
			zero OVER ep_protocount + +!
			%%final_receive_queue simple_enq
		;

		: _in_tcps_established { variable %pep -- }
			%pep @ _packet_out_of_window IF 
				EXIT 
			THEN
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				_$syn/rst1 %pep @ this :abort_connection
				EXIT
			THEN
			\ flags(--
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ this will schedule a transmit if more 
			\ data in the transmit queue can be sent.
			%pep @ _process_ack
			\ flag is true if fin received and used
			\ This will schedule an ack if new data is received.
			%pep @ _receive_tcp_pep IF
				\ true if fin processed, _receive_tcp_pep will
				\ have woken the receiving task ( if it is receiving,
				\ so the news can be delivered.
				#tcps_closewait %%tcp_state !
				\ close the window, there is no more data 
				%%tcp_rcv.nxt @ %%tcp_rcv.end !
				\ queue a packet to tell the system about the fin
				_$connection_closing ep_data get_free_buffer _return_string
			THEN
		;


		: _out_tcps_established ( --)
			_send_data
		;

The diagram does describe the implementation. The diagram does not describe RFC793. How a < syn> is treated when in the "< syn> received" state differs slightly. Doing it like this brings two advantages. The < syn> handshake recovers from lost packets faster. The code is cleaner. According to Stevens Volume 1, BSD stuffed up this state ( he didn't say which stack version), so noone has any excuse to complain if I handle it a little differently but correctly.

It is my considered opinion that there is nothing nasty about a nasty_gram. But they are of limited use. In theory a transaction could occur in 4 packets. 

			client->server      syn
			server->client      ack syn data fin
			client->server      ack data fin
			server->client      ack

For this case to be possible the server has to get its act together before the ack of the syn is sent. In the listen state we do not delay the ack. So it just isn't going to happen. Further it is not wise to commit resources on a syn as the syn could lie about who sent it. It is best to wait until the client returns. The client still could make life hard for you, but at least you know who it is.

The minimum transaction should be. 

			client->server      syn
			server->client      ack syn
			\ this can happen as data can be queued and close called defore 
			\ inital round
			client->server      ack data fin
			\ possible
			server->client      ack data fin
			client->server      ack

Enough of the idle chat lets get back into it. 

 
		CREATE _$rst1 ," reset received in syn sent state"
		: _in_tcps_syn_sent { variable %pep -- }
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP 
			#tcpf_ack AND 0<>
			%pep @ _ack_acceptable? AND IF
				\ flags(--[acks]
				DUP #tcpf_rst AND IF
					DROP
					\ [acks] [reset] 
					_$rst1 %pep @ this :abort_connection
					EXIT
				THEN
				#tcpf_syn AND IF
					\ (--
					\ [acks] [syn]

					\ Set link to priority selected
					%pep @ [ ep_data ip_tos + ]T LITERAL + B@ %%priority !
					\ set the %%local_machine, it is dependent on the 
					\ address received in the syn datagram, not the
					\ interface the reply is sent.
					%pep @ [ ep_data ip_dst + ]T LITERAL + @ %%local_machine !

					\ may set the maximum transmit segment size
					%pep @ _process_tcp_options IF 
						\ bad bad structure
						%pep @ kill_free_buffer
						EXIT
					THEN
					\ set the values that need to be set from syn segment
					%pep @ ep_ipdata + @ #tcp_seq + @
					\ seq(--
					\ allow for the SYN
					DUP %%tcp_rcv.iss !

					1+ 
					DUP %%tcp_rcv.nxt !
					#rcv_data_buffer + %%tcp_rcv.end ! 
					

					\ remove the syn info from packet so it can 
					\ then treated as just another packet
					1 %pep @ ep_ipdata + @ #tcp_seq + +!
					
					%pep @ ep_ipdata + @ #tcp_flags + B@ 
					[ #tcpf_syn -1 XOR ]T LITERAL AND 
					%pep @ ep_ipdata + @ #tcp_flags + B!

					\ set the ack flag as the syn has to be acked even if no more data
					TRUE %%tcp_send_ack !
					
					#tcps_established %%tcp_state !
					%pep @ _in_tcps_established
					EXIT
				THEN
				\ (--
				\ [acks] [other]
				\ it is possible for the other end to send 
				\ a ack without a syn. It's a complete waste of time
				\ just drop and wait for something sensible.
				\ Because we refuse to update the snd.una we
				\ can use _ack_acceptable? as our test for entry 
				\ into this code.
				%pep @ kill_free_buffer
				EXIT
			THEN
			\ other end did not ack our start of conversion
			\ is it trying to start one
			\ flags(--
			DUP [ #tcpf_syn #tcpf_ack OR ]T LITERAL AND #tcpf_syn = IF
				DROP
				\ [syn] [noack]

				%pep @ [ ep_data ip_tos + ]T LITERAL + B@ %%priority !

				\ set the %%local_machine, it is dependent on the 
				\ address recevied int he syn datagram, not the
				\ interface the reply is sent.
				%pep @ [ ep_data ip_dst + ]T LITERAL + @ %%local_machine !

				%pep @ _process_tcp_options IF
					%pep @ kill_free_buffer
					EXIT
				THEN
				%pep @ ep_ipdata + @ #tcp_seq + @

				\ 
				DUP %%tcp_rcv.iss !
				1+ 
				DUP %%tcp_rcv.nxt ! 
				#rcv_data_buffer + %%tcp_rcv.end ! 
				
				\ change state to syn received
				#tcps_synrcvd %%tcp_state !

				\ need to ack the received syn				
				TRUE %%tcp_send_ack !
				EXIT
			THEN
			\ flag(--
			\ [other]
			\ other  end is speaking complete rubbish, knock it on the head.
			#tcpf_rst AND not IF
				%pep @ _send_tcp_reset
			THEN
			%pep @ kill_free_buffer
		;

There is nothing to ack because of the state we are in %%tcp_rcv.nxt and %%tcp_rcv.end will not be set to correct values as we do not have the start seq. They are however set in the construct method to default values. We do not reset the %%tcp_send_ack flag because we don't send an ack 

 
		: _out_tcps_syn_send ( --)
			%%tcp_snd.is @ 
			\ default values are set in construct
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_syn _send_empty_segment
			\ schedule a retranmit
			%%tcp_rexmt @ xclock+ @ + tcp_transmit
		;

You come through this state for an active open. To avoid SYN attacks the passive open keeps track of syn received in the LISTEN State, moving to established when a reply to the syn we sent out comes back. In other words the diagram on page 23 RFC 793 is not followed. The line from LISTEN to this state does not exist.

The words on page 69 invalidate a valid open seqenece. It look like this. 

				side a                         side b
				------------------------------------------------------
			(1)                                  syn[200] ( in syn sent)
			(2) syn[100] -->                     receive(2)
			(3)                              (-- syn[200] ack[101]  ( b in syn received)
			(4) receive(1) ack[201]syn[100] -->  receive(4)         ( a in syn received)

The forth step is valid. It would be rejected because seg.seq is less than receive next. What happens if we follow standard. An ack must be sent. 

			(5)                              (-- ack[101] seq [201] ( error responce)
			(6) Receive (5)                                         ( a is in established) 
			(7)                              (-- syn[200] ack [101] ( b times out )
			(8) Receive (7) seq [101] ack [201] -->                 ( error responce)
			(6) seq [101] data  ack [201] -->    receive(6)         ( b is now in establish)

What happens if you accept it and correctly form packet. 

			(5)                              (-- ack[101] seq [201] ( b in established)
			(6) Receive (5)                                         ( a is established)

I think this surves to highlight just how robust this whole thing is. It required the timeout of b) to move b) to the established state. a) sending data would have also done it. 

			There are three possibilities here
			Other end saw our original syn and is in this state. 
					 --> sends a ack and syn
			Other end missed everything                               
					--> sends syn 
			Saw our syn with ack sent from this state     
					--> sends an ack

If the syn bit is set it is a reply to my original syn, or a syn because the other end has seen nothing. Either case can be happily handled by _in_tcps_syn_sen. 

 
		: _in_tcps_syn_receive { variable %pep -- }
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			#tcpf_syn AND IF
				\ datagram is replying to early packet
				\ go back a state
				DROP
				#tcps_synsend %%tcp_state !
				%pep @ _in_tcps_syn_sent
				EXIT
			THEN
			DUP #tcpf_ack AND 0<> 
			%pep @ _ack_acceptable? AND IF
				DROP
				\ our syn has been acked. We can move to the established state
				\ with this packet.
				#tcps_established %%tcp_state !
				%pep @ _in_tcps_established
				EXIT
			THEN
			\ Other  end is speaking rubbish.
			\ In this state we just ack with what we believe is the correct 
			\ situation. Unless it is a reset ,in which case we just ignore it.
			#tcpf_rst AND not IF
				TRUE %%tcp_send_ack			
			THEN
			%pep @ kill_free_buffer
		;

We have received a syn. We now send appropiate responce. The responce will be resent if nothing comes back 

 
		: _out_tcps_syn_receive ( --)
			FALSE %%tcp_send_ack !
			%%tcp_snd.is @ 
			\ default values are set in construct
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_syn #tcpf_ack OR _send_empty_segment
			\ schedule a retranmit
			%%tcp_rexmt @ xclock+ @ + tcp_transmit		
		;

In this state we are trying to close the link we have sent the seqment with the fin. we are receiving data, if SND.UNA equals SND.NXT then we move to fin-wait2. Data received from other end should be treated as normal, but as we enter this state because we are closing data received from other end is dumped. 

 
		CREATE _$syn/rst2 ," syn or reset in finwait1 state"


		

		\ we are only in this state if trying to close connection
		\ _return_string is used to wake the task trying to perform close.
		: _in_tcps_finwait1 { variable %pep ( --) }
		
			%pep @ _packet_out_of_window IF EXIT THEN

			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				_$syn/rst2 %pep @ this :abort_connection
				EXIT
			THEN
			DUP #tcpf_ack AND not IF
				DROP
				%pep @ kill_free_buffer 
				EXIT
			THEN
			%pep @ _process_ack
			\ This will schedule an ack if new data is received.
			\ kill received packets until the magic last received.
			#tcpf_fin AND IF \ remote fin received 
				%pep @ _ack_last_fin
				%%tcp_snd.una @ %%tcp_snd.nxt @ = IF
					\ we have received fin
					\ other end has acked our packet
					#tcps_timewait %%tcp_state !
					\ the task is waiting for this
					\ this is an acceptable termination
					_$connection_closed  %pep @ _return_string
					EXIT
				ELSE 
					\ still waiting for ack from other end
					#tcps_closing  %%tcp_state !
				THEN 
			ELSE
				\ not a fin received
				%%tcp_snd.una @ %%tcp_snd.nxt @ = IF
					#tcps_finwait2 %%tcp_state !
				THEN
			THEN
			%pep @ kill_free_buffer
		;

This this gets called we have sent our fin we are waiting for a reply. The packet with the fin set is in the send data queue. There can still be heaps of packets unacked. 

 
		: _out_tcps_finwait1 (  --)
			_send_data
		;

Our fin is acked, we are still receiving from other end the other end no longer has to ack as we are not sendng; we do not process the ack. We have to ack data received. We do this through the transmit task as that is how we get the delayed ack.

As I read RFC 793, it says to drop the segment if the ack bit is off. But in this state the other end is not acking our data so it is a stupid requirment for this state

In theory the other end can continue to send us data. As we entered fin-wait1 because we wanted to close the link, theory has no relevence to practice.

We dump all received data until a fin arrives then we close. 

 
		CREATE _$syn/rst3 ," Syn or Rst in finwait2 state"
		\ task using connection is trying to close _return_string is used to wake the task.
		
		: _in_tcps_finwait2 { variable %pep ( --) }
			%pep @ _packet_out_of_window IF EXIT THEN
			\ 
			%pep @ ep_ipdata + @ #tcp_flags + B@ [ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				_$syn/rst3 %pep @ this :abort_connection
				EXIT
			THEN
			\ kill received packets until the magic last received.
			%pep @ ep_ipdata + @ #tcp_flags + B@ #tcpf_fin 
			AND IF \ remote fin received
				\ we have received fin
				\ other end has acked our fin
				\ ack remote fin and enter time wait
				#tcps_timewait %%tcp_state !
				_$connection_closed %pep @ _return_string 
				EXIT
			THEN
			%pep @ kill_free_buffer
		;

We do not schedule a timeout as we have sent all data, we simple have to send an ack. 

 
		: _out_tcps_finwait2 ( pep --)
			FALSE %%tcp_send_ack !
			_send_an_ack	
		;

Other end has closed we are still sending data. A close will move us out of this state. As far as we are concerned things are established and we are going for it.

In reality the other end has probably closed and has no interest in what we have to say. 

 

		CREATE _$syn/rst4 ," Syn or Rst in closewait state"
		: _in_tcps_closewait  { variable %pep -- }
			%pep @ _packet_out_of_window IF EXIT THEN

			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP 
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				_$syn/rst4 %pep @ this :abort_connection
				EXIT
			THEN
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer 
				EXIT
			THEN
			%pep @ _process_ack
			\ there should be no new data
			\ from remote as it has been sent a fin
			%pep @ kill_free_buffer
		;

		: _out_tcps_closewait ( --)
			_send_data
		;

Remote started close we have seen there fin we have sent our fin and waiting for ack of it we no longer have to send acks but retransmission may be required. Retransmission is the problem of the tranmit tasks. Ther remote should now be in close_wait 

 
		CREATE _$syn/rst5 ," Syn or Rst in lastack state"
		CREATE _$last_ack ," Last ack received ok"
		: _in_tcps_lastack { variable %pep -- }
			%pep @ _packet_out_of_window IF EXIT THEN

			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				_$syn/rst5 %pep @ this :abort_connection
				EXIT
			THEN
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer 
				EXIT
			THEN
			%pep @ _process_ack
			\ ack of our fin will move us on
			%%tcp_snd.una @ %%tcp_snd.nxt @ = IF
				#tcps_closed %%tcp_state !
				_$connection_closed %pep @ _return_string
				EXIT
			THEN
			%pep @ kill_free_buffer

		;

		: _out_tcps_lastack ( --)
			_send_data
		;

Remote sent fin; we are still waiting for an ack of ours. We will not ack incoming packets under any circumstances. 

 
		CREATE _$syn/rst6 ," Syn or Rst in closing state"
		: _in_tcps_closing { variable  %pep -- }
			%pep @ _packet_out_of_window IF EXIT THEN
			%pep @ ep_ipdata + @ #tcp_flags + B@ DUP
			[ #tcpf_rst #tcpf_syn OR ]T LITERAL AND IF
				DROP
				_$syn/rst6 %pep @ this :abort_connection
				EXIT
			THEN
			#tcpf_ack AND not IF
				%pep @ kill_free_buffer 
				EXIT
			THEN			
			%pep @ _process_ack
			\ ack of our fin will move us on
			%%tcp_snd.una @ %%tcp_snd.nxt @ = IF
			\ ??? CONNECTION IS FINISHED??
				#tcps_closewait %%tcp_state !
				_$connection_closed %pep @ _return_string
				EXIT	
			THEN
			%pep @ kill_free_buffer
		;

To get into this state we still waiting for an ack up to our fin. We restransmit unacked packets until the ack comes. To get to this point the fin must be in the retransmission window. And the packet containing the fin must have been sent once. 

 
		: _out_tcps_closing ( --)
			_send_data
		;

If this occues we have entered the timewait state and the object has not been destroyed by the task We do not have to worry about restarting the timewait timer as it has not been set yet. Don't give the ack problem to the transmit task, it is unlikely the object will remain to have the problem dealt with. 

 
		: _in_tcps_timewait ( pep --)
			kill_free_buffer
			_send_an_ack
		;

Nothing to do object will go soon. Somehow the object got scheduled for transmission in this state. The timeout occured before the object was destoyed and timewait issue transfered to the demux table. Not a big deal something that happens when closing down things that are dealt with by multiple threads. 

 
		: _out_tcps_timewait ( --)
		;

We are closing down the link but we received something before all was cool. Both ends have finished talking. 

 
		: _in_tcps_close ( pep --)
			DUP _send_tcp_reset
			kill_free_buffer
		;

		: _out_tcps_close ( --)
			\ nothing to do
		;

These should never get executed. 

 
		: _in_tcps_error ( pep --)
			kill_free_buffer
			1 %%tcp_state_error +!
		;

		: _out_tcps_error
			1 %%tcp_state_error !
		;


		CREATE _in_tcp_state_table
			' _in_tcps_close t,
			' _in_tcps_close t,
			\ everridden by the listen vector in the server code
			' _in_tcps_close t,
			' _in_tcps_syn_sent t,
			' _in_tcps_syn_receive t,
			' _in_tcps_established t,
			' _in_tcps_finwait1 t,
			' _in_tcps_finwait2 t,
			' _in_tcps_closewait t,
			' _in_tcps_lastack t,
			' _in_tcps_closing t,
			' _in_tcps_timewait t,
			' _in_tcps_error t,

		CREATE _out_tcp_state_table
			' _out_tcps_close t,       \ 0
			' _out_tcps_close t,       \ 4
			\ overriden by the listen vector in the server code
			' _out_tcps_close t,       \ 8
			' _out_tcps_syn_send t,    \ 0C
			' _out_tcps_syn_receive t, \ 10
			' _out_tcps_established t, \ 14
			' _out_tcps_finwait1 t,
			' _out_tcps_finwait2 t,
			' _out_tcps_closewait t,
			' _out_tcps_lastack t,
			' _out_tcps_closing t,
			' _out_tcps_timewait t,
			' _out_tcps_error t,

The tcp checksum has been checked What we do with the packet depends on the current state. 

 
		m: { variable %pep -- }
			\ make sure packet belongs to tcp protocol, if a ICMP message
			\ at this stage it is simple returned to the free buffer pool
			\ more should be done
			%pep @ [ ep_data ip_proto + ]T LITERAL + B@ IPT_TCP <> IF
				%pep @ kill_free_buffer
				EXIT
			THEN
			%pep @ _in_tcp_state_table %%tcp_state @ #tcps_error MIN + @execute
			%%tcp_send_ack @ IF
				xclock+ @ tcp_transmit		
			THEN
		; overrides :consume_port

Exciting times, I even know how this is written now. Write the "listen" state and I can start testing all this shit. And whats even better I know how the listen state is to be written to. I know it looks bloody simple, it isn't like that when it hasn't been written.

This gets called because something somewhere thinks it is time for the application to give up. We clear the write queues because the application may be waiting for write queue space. We set the state to #tcps_abort so the application finds out about the sad state when the next write occures. We queue a read packet with an abort for applications that are trying to read data 

 
		m: ( reason pep  --)
			\ _return_transmit_queues
			#tcps_abort %%tcp_state !
			_return_string
		; overrides :abort_connection


		\ if we send a packet out of sequence we should get an ack from the
		\ other end. The other end should discard the packet.
		: _get_responce ( --)
			%%tcp_snd.una @ 1 - \ get a segence number that is out of the window.
			\ receive window
			%%tcp_rcv.end @ %%tcp_rcv.nxt @ - 
			zero MAX
			\ where I have receive to.
			%%tcp_rcv.nxt @     \ the highest consistant sequence I have received. 
			#tcpf_ack _send_empty_segment
		;

		m: ( --)
			_get_responce
		; overrides  :hay_you_there


		m: ( --)
			_out_tcp_state_table %%tcp_state @
			 #tcps_error MIN + @execute
		; method :transmit_action

Deals with sending data out. 

 

		: _tcp_transmit_action ( --)
			\ this gets executed every time tcp level is run
			\ note we look at first item in list
			\ when the execution time moves to the future we are finished.
			BEGIN
				_lock_word
				%tcp_transmit_head @ ?DUP 
			WHILE
				DUP [ %%transmit_time %%transmit_link - ]T LITERAL + @ xclock- @ + 0< not IF \ >
					\ this and following links have not time out
					_unlock_word
					DROP
					EXIT
				THEN
				FALSE OVER [ %%transmit_in_list %%transmit_link - ]T LITERAL + ! 
				\ if further action is required the routine
				\ being called has to relink.
				\ This is done with tcp_tranmit, thatr word can be used by anyone at 
				\ anytime. Net result if we reschedule a high priority task has also
				\ the soonest time will get used.
				\ The unlink will unlock
				DUP unlink_double 
				[ %%transmit_link  ]T LITERAL - 
				\ link object(--
				:transmit_action
			REPEAT
			_unlock_word
		;
			
		m: ( indent --)
			CR DUP SPACES ." tcp_client | " ." Object: " this .h 
			CR DUP SPACES ." lc box  : " %%local_machine @ .h
			              ." rmt box : " %%remote_machine @ .h
			              ." lc port : " %%local_port @ .h
						  ." rmt port: " %%remote_port @ .h
						  
			CR DUP SPACES ." priority: " %%priority @ .h
			              ." state   : " %%tcp_state @ .h
						  ." snd.una : " %%tcp_snd.una @ .h
						  ." snd.nxt : " %%tcp_snd.nxt @ .h

			CR DUP SPACES
                          ." q sent  : " %%tcp_queue_sent .h
						  ." q unsent: " %%tcp_queue_unsent .h
			              ." snd.end : " %%tcp_snd.end @ .h
						  ." snd.que : " %%tcp_snd.queue @ .h
						  

			CR DUP SPACES 
						  ." rcvqueue: " %%final_receive_queue .h
			              ." rcvpre  : " %%pre_receive_list .h
			              ." rcv.nxt : " %%tcp_rcv.nxt @ .h
                          ." rcv.end : " %%tcp_rcv.end @ .h

			CR DUP SPACES ." rexmt   : " %%tcp_rexmt @ .h
		                  ." rtt     : " %%tcp_rtt @ .h
		                  ." smooth  : " %%tcp_rtt_smooth @ .h
			              ." rtt_dev : " %%tcp_rtt_dev @ .h
			              
			CR DUP SPACES ." rcv room: " %%final_receive_queue_room @ .h
			              ." pre room: " %%pre_receive_list_room @ .h
			              ." rcv.iss : " %%tcp_rcv.iss @ .h
						  ." snd.is  : " %%tcp_snd.is @ .h

			send
			DROP
		; overrides :print

target_also
&drivers
target_definitions

end_class tcp_client

target_previous_definitions
target_previous
./version081/tcpippaper/0040755000000000000000000000000007303262312014000 5ustar rootroot./version081/tcpippaper/forth.css0100777000000000000000000000100007300314370015626 0ustar rootrootBODY {background: #FFFFFF; margin-left: 1cm} H1 {font-size: 24pt; font-family: mistral; color: #808000; text-align: center} H2 {font-size: 24pt; font-family: mistral; color: #808000; margin-top: .5cm} H3 {font-size: 18pt; font-family: mistral; color: #808000; margin-top: .5cm} P {font-size: 12pt; font-family: arial; color: #303030; text-indent: 0cm} STRONG {font-size: 12pt; font-family: arial; color: #303030; font-weight: bold} CODE {font-size: 10pt; font-family: Courier New; color: #800000; } ./version081/tcpippaper/icmp_udp_error.png0100777000000000000000000000731407300314370017527 0ustar rootrootPNG  IHDRTIDATx*Pש}NכjV@@iǮl ~$N@0ww IhHB@D"$4D$ " IhHB@D& IhH q`❌r@D"$4D$ " IhHB#c 4GHhS2)o" "rQ^r6yg |evW]i k)lHMHh`^ې61y\V~W:#BLFa\EkV7k[]r҇|kFhSc5VGǨA*Qn Zq՞3]g}aCgSǒe: !ܟvV1;/JHh pa(7D$(; "$4D$ " IhHB@D"߶4?/xoF1 IhHB@D"$4D$ "S@ Ţ9ʁ;Nz i>/wj:mN߰`Ozٱmܻ WmتpMJˌr0r09z,PSêbm߸D(W)mpy4CBM\4r:C.DXV/9ᔟYPfwfUL<-brTXը[׭l[CoevޙK-s tLyX3bӬVmK6{8Nf\nr<vޙ!ygߚT.<Ҫ8ɈI YGKO6g;1H~ 7jd~]>@lpV+O 4Dԓй)wU党 :M[j~fk0\s0-UӐmڄnjk65}hfFV^&@vScۅ'e R*^Yvv`Q͕ T_ڍ@3@D.ѓEfe2g"$4D65'9=ͭF@Gݓ4?#H}{!c }hHB@D"$4D$ " ^WM+} 4c_Eۄ쨗T2gAscmU,,\NHֿ-0/_VyyM [^ͅwo7^NBxQt׫N(@rz5k,/lFj~ڄm]/㦊˗\~X[H*Յ\ 1.ߘ{]^XS`USNGSڭBpk],q{]ޕo\s'5wL_;woZؐ݋E{WB?MscVg+urUQ5q{]>~ǁ;|`\L,+u #K?syI֔…+xauV?y_vo ߦ2q4.9%>}s .6*[+{e~}6Y#yT0/G*?T`M_ر\ w?(65`8BB?/Z]i--,۫|da:Tξڂ?RMy}r-$4iQ;>PǕ5MLGúv#!;vo5uyܹʿ {@Yc+ʾ]@\wEsU29PrynuVV{)wo.Ї>];=Xgj`}hH,z IhHB@D"g!+/@Gf_5{'2 IhHB@D" "}x>(r7А&x0 IhHB@D"$4D$ " IhaҮ\I~pKBcP퇀$4D$ӧ -SXU^9WuUXry޴RA~t~k[v@=R(7D$Dj8_!$4D$ " IhHB@D" i~ 7a $4D$ " IhHB@D"aB1BB@D"$4D$ " IhHB@D6kKh5r@D"$4D$ " IhyN1$w1Md"$4D$ " IhHB@D"$4D$ " IhHB@D!'e[KY VAc|xcK[J hsxзW7Ƒ܄N/]"g$trv5kmeUms+[L{C;FjvŶuaQO6Ú s06-UCvcyәϚh>h<w7`Fh/ ?oM|5vnWeے -l]FWCaC *i: q;xuْRW-\ ^]!뒻ww{uʇҴsq?1'0ʽ+E]-:#5p[ "լ-G5W!\WZgkVOs 1Yfs T[&5<ʝ܆nnvۼUyknUJo]c0I|.scYF%GlF^Տϭm~FjXQnhc_ @ :H"$4D$ " IhHB@D"$4D$ " IhHB@D"(<#IENDB`./version081/tcpippaper/interface.png0100777000000000000000000005053607300314370016462 0ustar rootrootPNG  IHDR\-{PLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4DNIDATx]IfNҼJ;UlPGoL{+ YC6rd>I+n8&}. /!Wx L(]oN~]_EDW@`C} 9 $ǂ&/H@0D7ٺ}YwQ/bc l#~`|$Tr|IgB*fm#LA .dv; D!FZE p "C9cyZ+pU)2$V%/ɠk G/q [Q$ gEz$+<ԵGl3v wQs&i ϡma8,heIr<V"VN+&b9,pndV?A?lq%"@FϜkN:ŇM-kmbkઆk8B9Y7) /{eZP2Oqَ W@K9FDknc0Zr^V (SԆ7>[s>BfZDrUgDDp 5۰鏏\0 Qbg[o<5 PhqdaK(4n勤ư-/l0:X4ۍ{2SIa% G\ \ U`t4H !CQ7OSFOW,!A*xXYB @<H:6|.y<ξ LvZQedE)@8AL4eotF32LjyqXA)D>ƚDjl&š:4IDsi"pҹ48\t.MN:&'KΥr`? 0j{  ^%g_L'"n n假gbl۹ sR~0 ǃŴ\ dHhUexX)`ۧj0ԋ@B߃n8x[fF)3u@@η@~@j0s!;UC[ҭ V |#XO~5 #;!la! L@ະ嫬҅q77&8s!Q–}Ho0'ֿQkwBl@PR`0:|el9{Ɔn+Rfph?׿Y2-LO#(@07ݒ!'dAV#'ӈ/@a1sq/4ROcY)`Z"Cr C V>ȢYIbجyfAG1F@ 5(U y_ 45֙'kҢ0ix/'j\^! `.>ȗa@ 1:MpQSh4&> 6z`7 VxygL`h"ŗZWaRb*k 0_춽GIsxOµ`>x{`(c*ŤF-[L2v2&?QưFnFB(jB 0abP[pϩߚ::/LV,錗Q{'48`[C<ӥݓ,*aB-I'\jy 1PdD(0r`}hXU1Wʓ: Dk,Ɂ瑺HcN+Y5ޓ\z=0*A92L~csxfr.|+a6#|'YLH6ҟ;xdK Yer}:|D a3g0yc`"p;E $^P"QD:b7z_RC@"ITyIz<[' tl6 VZ ?U]sxh z6$WC&:gh6r.+xcA^M@ٕq9JUI9Юv ./wȾ#:B`/I0uj[C3^q@$f~x[Y'﵀9r Lc1U1hdqvђ" GK;>P:C# @&2K\~ߚ@v1X:xR= ;F2fcL `Něy)e4t}=&(x:^4882!Y%b<[x8&wwDm_ &?Xh*6@^3c0I@P[1T]4=Y@`,v#(8Ja1JuHۑm3¼ &$Z-E͡AD Zhe0G࢈P ׮Ҕyk:5YcB GaLC7Wnc"pwG`[V;WEXAr`d-mG@rAp O8cT7Ȍr#xT\,oZ,ʁBmjTWf]q'ww8 $MAY;kArc8?( f|Tf=2JY:/7uv?(z'wt% 5" ڣ'#:#JT`Pp + & M \xOQ֪TG&#;1oH&%1n1x귦"t%5kH6phВw@If8>ܞx 2|$G:FՁt1Mܶx"_譲20m^6er$+lPjHӌLt6Xi |1ZDٖ |){:5Ԡ0hdrl(rmQhsxW {gn"y5j5#ɠF׳28F>c&  KD`{+!Y|+PQH! iLEZI+{<#Mxd߶dd 8A"rcjʼ5μ1Jp k]˓VG.yrM&u]iNcLJ8A SA;`vp]!."bs2=S3t敘 iF&}MgO~ |=]p&ML+Wp"4i:@^n7;Sգn!j-+(l=;Ap4%l%h%CDLt9F`*P buDrā' FL 0H_70߸16tOMla4vX礫S)pi2a:Vm03vmhPEJ"2:>`Hj#܁J R_X7\Y#K g&ݎv4a0gPYmŔdmm/(Ơ' ș0 tä{Q&I}F{}5 eXZ6O_:{'eE HԁV("=^V y66^U'42CP~Hd- e23"u,d *Qէ ԛ<ׂ<ӤHi,0/͓!U8 .R%ϊuNUTs!4"<#Z]["fo L) ތfLG%Ux=*7qq,5=!ŵ-?S\K-Yh@Ƣ6vx !\3l,&ir=Yb)`"?Ҵ]<8Wa'd>ĞA큰+l,7O < 1Q| ke{O|5-%eEٲB53#ކpW@Au3ʫYd 9f־iC~+=Zل%{9ϡ~a gN3Xnr$O2߂>9i_Z̘G cI8v5/پu+MeisrVVwAWPJI:DBBUl !8ڸBT33rM$n_0X_5J] Cpm U9Ae-ݴ`a ]HpTpˁl[`gScJ/؂"p4Aa-s@H֦S<ᐦT@pz8``8^ΪދgtvpC)%r9l|DL~5)J+fȁJq6U kz]30+Z?qȏ[:^VKS-?Զ7jv:Qk%}f2}mg%Z+o;]K:c;2'1fU;.sfgo\12y ,9'4rS=EW>o@t",-OCȁeS)2 !F*hcp:H$此y.<<"E! x>@Od D?k"}ڠc;";1i 5-!ʁ}օevR©x3'7(a7Y8r!' s Gts ފ%t bZC fˠt6 ZvXG@ 5s7ND"+ v!Rt% Bq%[%Wa5WdUvX98;j44oW"mf=>.<隷3>.'A4~x5><Wƶ8@1 a+.7rU8ppCA #"`B*P^^z-nu:yKuҕYD\ +Q֥\ۊIq+>s.<.9pŗYN[0k9\+k$PXvP˝l9|\6]x]u_oT?E`!1&SW|JL4("MĸtZ=oE'l΋/kHa| FnEXP4B0RllGP~]Vi؅g{#a 35aTz:/:ؘ&\_272[xޗ:v2}2 nVRX:z5~ݴe:>=" +jy <"YC+daZ+=.@ /Zڠ|1[7_hJ'0dq`@:o< Va偽6=@6,p|sET?;:+~MXtlS jQV[DUKZ0rUo<כR}rGnUy -dL49WMPѓi3*+BC!PGTbjSo@鐭g(#Y[҅B͒vmA^Ƈ2YO.MRϲ`ڨهQ^N&Z6'`:8x];<<|ry !r ~wD ť’؄Z#"k"J}5ON90 =4m\,![ڡ亀x{UVxX*彃jxu0Ɗ UW-EI mcw%07K7:wЂ@)SjU4m-}5Zj VNPlD'<Ƹ>aW^t5$U|t™)b^cd\=`b2lG!̴Hp}nw4V m,x@p HY"z?oV^ e fGP,Pdx F ,G9bӺqY~Te8n_F8yX\wOK"PI]r<{ @*O=$J,I w=ooO@^I{ k;@WqHa7j|LQj]-[DvG*8e<0n1bVu0un^_*rqx2o 豈F<0ͤUYF]Sz1QS+@dk[m__r'8_?vC&#QǷ/%vXG:#F;'F_ (ga˧x`zuhEpϝY9|ޓ?jv 鼛L%~dnR-qzaJ;BY;hݯ؉@?v=~';>x{`m,Ba,GG?߿zʏ 3+쿏i'Ҕ;gPxh_J~]{,:Gf_6w2JJSĽ kX%2y}1 jehKS7߽gukʌqھ3^&X#;&1N?w.;LnML֊ԬÏE`dZ0{)u*q=_q .`q/ 8^)sk=^XȝU"uh]7p A:6Գ4< ƶvNL w~y[\k_ Z|/Ho#8G30Ns2e:]=YG sgQΝɑ'!0 taF׺̧U`,mX:"џ(:f0ls1fd,gcaݫ.N˝M>HIcc3 }ˤh^v7-5ND8Ԫ1MHP7"P|¦]m5֌M9Bs;>n]n #" PPe9Cxy~"wT:hNS wFvyq/8@~aGk"On( p^9D|`ŃX'n9@D{|nh^~@{j8 z C Zn7[֊Vq#x;|*{D~ D*wQJ~<0I%{ΥWaUaFSɦ~PN媹s\}t}!zc/6߇.WViv/wJL'Bp"0Ny$B)z M}"24K/򾒧D`.w/wBDsٷb"[1x}z>=VL^}+&OϾקgߊӳoDٷb"[1x}z>=VL^}+&OϾקgߊӳoDٷb"[1x}z>=VL^}+&OϾקgߊӳoE;!ZLhCpɌJ]4%uc ɤ= g>??OB:ϳOU 5 8Z$/B| #~}̮85c$ [Q9fdml GQoU0OMnv *P `)G>spML00z܄fWF j'`ƺZAn7{?8C_oyz<7Nbd!\2y&-ݤɅZs"0^/T'9 WZY;~@x=pJ5krwy6Cr9P!PyT' [{6obWZ=&24z!R U?~0qbD`ĝNV 41hd @ ܟ&ѯL0˹KԈ,l,D`j^-[z!֬a/2F+T}Xr*$EϾ$D>^I1ZyU$EϾ$~af"' خu7uy"0IϾ$GDGT$3mD=Iг/Q<0 kҝi"0^Ez$'i"u ުN42(ody2<^7xせz:n8;6Z( SC[UȈ@@;)l_!sW]A%oI]@FMsW%\ [ vIxSjYQvm>!]><0BI =KK"J.!.<4Edahy&e$S=йQ NrMO{ˮenH ru"}-A0hh[f -qZ&ۧmZW09Ggct"$mӛ&=WWMGzr 4aJm؂-99kzYDQ!a%yKI›16nM;w\8jsV=Ye &"vbsN [0I+j{/kSsJӞiPsr_' :7ZjXcJ//9zyw$U\q!J@Ҏ4Ot 85r&Șl#YOoʸ䄐Y#'H<+0}Mo.kĸ~ur,}QZJ9JF鶸Br:B8 YHq=n83=NflK{M>$+ bֳ}:`7H2GAr"^h!^ `9S{.us<˜+)>ëp̃@>`tNN6TTk<cFoV\ W[OBb܉"޵v9{Ll 9G'jsP'EoV}bXrl|` Y/lzycbxuUmN:4B$ tj#9cPMDWz1 A !%t^9Amum#K6L͠39uAՂTYf5[&,=BO ;D`CE@;1vEvלsv>k]~M3>B7lc􁝾?s ]ԡi3|"( Q.N[B+֮ްaFL:{zLzX&Lp@JPԃְD<{b?P~1&ol _,}<>·dޜ˶z>+(q `w_z@ B`Eygxխ^+`Usy>M~ N6T6FgU)0/͠c\ͼ ș=kϹ/3xjSW1uBD`CEeH-FNJLhY ]Wufw31"!8V]*N0}S^}G@ҕҥҰt L2.ﮭEzU!74RTI)h0^PC㟘=Yqߜ:iJ&e FmF j{%8A$39AwC@`"M q!جw[*{GXcv ,vcd]X1U@B)OӫFus]f-!:ʛ#8 !I4fJ z?o /<;(V`ŗ5@J UoI-k.m9\8&*J-L rB️~,7jAo(eA5έ.^K|Vtk-^]8kʁ z\/,el?c۠zVK: H!pe|-[fe+JϥAA;EmA9MX  B6ƬuMpCwƼ8[?q+ Y|+`G\{Xti8y{ke;yocYV ~_33萱eCsym[oՙD`P2_^[EC0,Ҍ(Vј EcA0G\ѷlI&hX|` Ad*N! 3 [/˯p+K31e*LrV'ɉ!e5L4CwxB͡)}Et̖`mν)9Ds"o"'"KSqzO^O?[BD?o߭fǦki[7L* X_۠gc27Un&R0_zrj}w9OL鷾t7G/OE`*Y wo6FcJ1".PQY$\Z|N8:Hi!+*usCQXԣv!@'iy& ?Ky3D**us6(6;C'"*.L"TPmzrg~w$F e ur`&J2ίW:E**prj!֡8t@̱,zHd[tG+efok~m{dT[3=P`):{'ϒ.7RQY7\!ZnԴK/g.쁘5Pe|Qkͯ.2jfܭRQY'HAQdΒ_oGfL>@{|,qsJ;4%.?p{A]+=]LԉTG cy^[,k f hn_?[RBx"h/$õh%jw1@׆7^3%&ԃ䣄c}9;_f&oٰJd|Nˁq0C;tߥ3{D`NG5df\')p#4Ҙoj]p"0²D3`K3-?T$)|snSh"Pm@:pO6U<Y݅&p"^ _Ho$ 8@A h"4Dsi"Ҝ}Dh"bҤ#i"pҹ48\t.MN:&'KΥIR?쨙lD Ӯ{_B{3޵gKff{UOކv#P@I` ߘ&K<Û`^wm2w]zrS2|.}j@C_8̤~<Vu/?H㉤+(4_as އ9xbKd/B,`,wXZ9N-9C}i:+V.`-$$LY>ԉ@|>arb{g `#dwC@-,j,܌@݁&a&݈Ӆ*l7ϱ%j ]4`0>̤H3mӘ^M]~kĤKЁ fQ;\ 8 Tg&]A H|/aA}IK)*m81́%@-'d»PA`LjH?p|!2|/:vvON:RfQZDD ׌; D,.nA¾Ƒn|UZ)܂~rŻQEڻeAqS0Q> !B#Б5}"Ic;#!NVR ˸U07ԅ؍O牝"p5>9AU8՝ #3iқ#5Y%}Q-&'c ,[LN"4E@RŘOΝJqUK I9.wBuFwˤPWnI8p5^|&i7iB~ v~\O; &@0d~m 7\@N.|ʊ0sR ? g%ByfssR'y1˧9zG"h* 2 ъ)DB%*%f[-D@"/Ѡ-֞m(4@.LMEh¤ [Y} 0i9-ݦ͑]oO!1 ݛi(90syizz0.?<>@*Y2T̚ N{1kߜlII.7i0AXx(+.t'tfըϰ}L\EƙТw2ӦRK8|94[:7aGSwPp6cfB|E6V9GzAK_Xd/#I7mzGN *Ȋ͍j|2#u54uOv;3C^!u7viSUZtK̍ΣHg@ـs* Pˁ}R9RG9J).DG p<Y2O zyd"**3wV&LӿUT Ym,̡Wh6VN*VxMǙ\}2tĞ(ENp#=_v$x q% mEWPJˏ]|vVfQH6ʹ2Í"^"1W+"Ise\_knXM䢽b>#FP^@>^uAd};_ޅm+^|X8uBIw_mU`ZGLoc\V~aa̽C/)Zx#yb*㹺pJ3'Ζ20ܖ94 r9J_@=BvhB8vI g^alF[&Bx *;DQ8}#6*JbU-; {و3KE Xyྦྷf#78,Ҏ=^"}hTNz5Ȇtd\ae|'{jV=MKU|O}&Nӥ<Т׽7 {Ez^(҆W_&®uI3Ѱ=vOBYEW Z_`#\9W$?T]`Q|2XYL6ȽGQ3؅8XXtkod}b6H;S*d@mmJN:YcgIr1/JCe![E2s=V(cFhvk2&Q?ե,^y-7C`nA<0f2FsTvx.+[[F 7Ћj>P >UZh>Ǫ*r7e?Z%n^nB˅lV&BxʲgG<^nեo'xCލ蹬+BTuᕊjУG'ܪq|n[b7[)<]ⱝ?}f[ul`cShpjXzh :Ѽ0ѭx7P9fj%Wg<,|gֿmT ;iqڱGOD`C|1Da|$B9A~x.RtԙWo&8303\Q֔]9A>J&s2]})CքU!΅7Dią 4LJ܍3ؕtflLNfgl-Twd 1*@l!9}SvZP Ωc6 q׿X#9>?^Aj79b(aWG~EYYq>d2}/ (?c$x";hӒjFǥwy~R t))O>b_#[ ]zdف|g%z,nG#bVa2W$&ApA_,Ѕ~d A68,\#k&xodS tM怾e^k+*T@^! p5Yi<x"ǫ%Ju]^́fdݒO g !^¢t"_ r?X'&7}Lc VOW/"p}ڏtrb$3Yl4•?q(ģ-D% ?abز]m#J"2T g3ˉFCsY l^7D)k&x`oGBBq&mdjR#rDDw%Ѩ3܉μopcJ¨Ε {W#IatT@#Y;`'I\p6ׅr̴cD]Q/L.|OHhjԘ1hXLohPQÊ@+(;2Ya )g ;y[4Ŵj"Z-L~L|wNq!cyȎd`7zoyۇ[4> oҞqAûNCI,mş\> ;gaaLYiG~GJl H=n2Σ.\ QcQ >^>IO{墑iD_Y/"/ <*O!zBدEO:8w?YօxEAN M}ҹ48\t.MN:&'KΥIDsi"pҹ48\t.MN:&'KΥIDsi"pҹ48\t.MN:Sic/IENDB`./version081/tcpippaper/interface_local.png0100777000000000000000000000321607300314370017625 0ustar rootrootPNG  IHDRG0PLTE{IDATx OW5.=ӎ'!HA‰x!޾8'fN5Rq'FJ'f.3ۖF[mCt!L8Vܧwpp1ˣ4fC)qȤ^Qs¨$^" &Ϗor3έ” 5dA$/t+#Vrx~8pX?%(icqfӁb3g͵i}cZ!&+8$+M_%gŶ/WuXH)Z嗓G<+BK){3) d(VRKZLuf <咬^VZ(9pд}XHx^Y9rU-[F,$[*g\;+jVY|pMR݃c":juIXH'8zVnф>! :1:w5mqB[62嘭W\εK8FyUmʺ%0W6lj۰7!G?Tx.D/ GY.Zo\(:8f(gΰ3zWCJyԱH^Mu>''yՆ8س{gci^3靾8g.ꚽW*,p^]Wq>W^]q`8p8pa <pe8/w08 1qR,Ԯ.a#<$kIEO;H8]>$XɌ3GԮXhiv2a9dZqX),Ui^LUlٯvZv؁:~mr,}cEWOp#S|C&# 9nf/@t0SE+6"t("GuqV~ i5"4Ǭ_(s[*.k}pjOT_HE^lNǯpr9լyp|4?SrH{|gfjRdj- GU^VMK6릤Bq$f.nf-=:+Qq6.QQ[2yE1.9 fԴ!EsʾQT^Ep96OF|5p\|TEU>p\o95Iܒ3n8q疜Ջ];o|%oiy 8}ԫ8f6{;K83&ǁ8ꑣ;/q]wʱ}acՅ|g4Ǫ 9wuDZUppB^v}8ȤSG8'UiU=F͕ը$>Dc|AsJ":z G"A~?m8hAyyHWkppAִC㇃wyGRwrWplHTc:y 8p8pxv;8+#VGX5m-gOIENDB`./version081/tcpippaper/interface_loopback.png0100777000000000000000000000165007300314370020325 0ustar rootrootPNG  IHDR80PLTE{3IDATx w`OLx_gDcd= 8$dW4D9;K|!liKD&o8̵R!a5W?&bf] 8*-pKR#z #\84Wۚ溮IW p3%ZJ:3r6cN%MvW<'KЦk$\qkV)2 *(HN) R?8p\38p %yS=ȟs2#h{/w\9Vڒ)M%WN> Ys*\=28*rv5t:j>0BrVykX5Yp-"8 =u],XsݕDýޮkeXKpm6$+#ɑ 8]}͌m]9ll*M@s%w@">wm6 kLVnMx;9봜%RitX;6YX˖Sl{kU{撃՜327oH!n>J~p8Nn dXmOpn&o^%9ֈp"Qm.{3Xs} u=rkS8{0Zsss9G }ᜣapQ08a9D !j:y5]KL-Ls42\Dq y n8p8p\oFpn#IENDB`./version081/tcpippaper/interface_nice.png0100777000000000000000000000574307300314370017460 0ustar rootrootPNG  IHDRz6"0PLTE{ nIDATx v0 D}, a{ D/ o.P.-CDzH!"=D"CDz:ywkӽuw;>͂((=twg!83:I'=Gz3Mr^.|r/jgF.JiՄ79W, 7;s= mKy tw,E5=54*=-SEzH!"=Dӛ¢wzGA"CDzH!"=D=ٱgC'3Mmmb$ xEBE_v1{/ӿZ~D.?z=Zn( =˹M̭cg5f9JO: XМHOsn"+9/NuXz-DI+i3Z'4}$>ۿLKf'b鍋`(=ɕO)ތLQzMr~fY}(gdf}^NfEO4?2G%$맴v~HOz)`%SJ?`(?9TR{h8YhiR)|-zu˹˽L/UyO5/AԹiԹ!Usb~W=7: ଯ+uHU΅촔~ C/ާB %/uI I=Udwk١ЋtLw9*4:a_DOƾʙ Cޞ+8s@O&b ioչ;pd}+ԤduI`|o>{◶ l %\7Lo饫I~|N!zMyOorhp|,戊P8ucߎԕV{9BZ$KUXr7%6Um#r|B(7jiuD+_szS=oYa oEm#_(v>@[~:S=S'Kl^ȴ9(r[4-M0):dkfun2oR[FlՇ|:@OiO#Cֽ=-ʨ69=rtw-ݓL/ퟪ6މ)e:"=°XtwgKF^oF`<Ж{E{Kuʂ|7di'۬5,ev!g`cz|wU8Cij;;o3_|Ck]}7~:t,̝53p{zÉ5]p7*g~o>,YڛЫ{iyzrAsnps!z',9-h {8rhN=ҝMu U99BOԩ'xO˹8Cp<} bC"=!H1Dz!C bC"=!H1Dz!C bC"=!H1Dz!C bCwPӃ ahPH!"=D"CDz.Co2|C]8iMlơe9/0lb [ϲa%)Gz BM/4SƩ3㌜KO6z:Q{46IJ{DOYڋ`u hzBYiq.$ϓլs?3!g&=̤wC]"=Dbg#;8+sޛgwDsz6iU{o] #KYM#8<_+T/}YYsi=mqH/}Wt~ehP.DϽR9Mz:iKSu3X;seУuLDwP;{ѳ;%=o'N+G#6y9Nߋ^VYF7xtfӿWbE==i/ysᚽUD|Zy:rϱ[tҴRxs}Uֹ۲K'Y@~c?*p}'RmݘͷoLsqWwwFd㏠7XJϠQsӪ05DjRcsxa-uׂ.Iz^I|j啌I%8]V9 wCWRofYlrϳW׹" UOcu4]CcDzCo ^c9iC&=8+/a3ˆ6qT<##*I\zp& SK-'93>>XtRuQӫ&je3LDz$](DO;gVaҳI6UNLҕ1r/ӳCB/NҕXZZlJ>ߋ |<14vKפ7+.{o;ء. ;::MzӢb#x˕"S./{O;ԥKˏoKc-sH}r.˽>E)}ֹNI qIqIqIqIЕ=}C"CDzH!"=D"CDzHXn{"&m͌.۝qC;3Howf ̈"ݙ7Dz3#z[QuΌ*CXzMݔ^ؙlƶJ/.Qz_ʽ["CDzH!"=D"CDzH!"=D"CDzH!"=D_}E>ӣEzH!"=D"CDzH!"=D"CDzH9$g8sD&IENDB`./version081/tcpippaper/interface_rti.png0100777000000000000000000000240707300314370017332 0ustar rootrootPNG  IHDR]`0PLTE{IDATx Es#;,.H:X\#!~H,` XE~ wʖÄ5abo7{ܑJ,Y<5,xX,,Z1Ja}LX(ÍU.@3lPaS6v*8(.*U;0D+ XA X#`#7FLFGKf_&ɖCle_k:ֱ޼ڳr,fz`hZ4W?wchK}=5;8ԛUb JlcR`M%0@; ˑz`UNJl]b"ƫ6K;m&KUgŏ% CX>^V*j>j\jҰڍ%>Uٙ`u〨vvJ,zulՎ`y=X⌊`OOa]njbw-3n6X\Oq,]:UaT2]op֭Bz+nr2ؤj1U2 gnF%nlQXčs6mRfזMfB}oW3lhKVv;`F؞I ? F|XεX="W+l{lTdû`-mUTN}##-IeղU7Zv_ʪfEcn3dg9،)۫ۢ 5e#'W͘ ۠Z֏hm}Q:c@MƳ7U: ^_21aMϦ޲!bdV+\"73֚61۷e$zbf8|4Vc_L{:g?Dr*R X,`۟!؃DM ۛ1ؾԏe~!+ Y}4+mGR_~> gaJ8l6?vV\~켰'`OdMaߒW,_XA X#` X2+4QF;vVY `g?xjIENDB`./version081/tcpippaper/routing_task.png0100777000000000000000000000414207300314370017223 0ustar rootrootPNG  IHDRIU>0PLTE{IDATx흋 DLBAQGEsƻl FMyڂ7"RBDJH )!"%D"RBDJH Q JtQR|DJH )!"%Dk(>k,sWYx.EJSP?=n}d< O"bX>Jls kIBdL4P"%]ޔ \KIꀒghO.YJߤk䔌)]YD˵gudyIʼ.,qy-z$zɔ%BJ.dK7$6.\1KKk(wp):J@9%,Y /}j򤴜8)^f+)󇔐H I{)IzOJP*B$@KJZF0Ôݧ^[4sJcӔM)5Mc|P\=y4IAIC=F/]]bS(ULW#! fRЗ0fǷ+l[R6f(͆2,ل0(UM)]R/J 5J1&U0˜xzC31m\V1mX/U.gyɍmHz)y֐PTϷT0C ٖJ W_Sx4 ^;PQ; ?i0,\8B]7  !}oE Bv3r[:KJ4,`3p ȱ!JvP':W5:Fas:ذ߇> L$iJ!ii܏N On#u”Ov|D;t * CD:~FkgBƗC8    z@@P@@P@ \lVBkW>CAh&  B+HLJP@’F+` fF2 945Aķ ' lB  {sX,K[DoM%:zkuBn? aE;D7j0 ؏—̀@ \4r@p>*@x5zf3    ͍e$Df>z@@@@@@!SSw[+\7<[i@7-&v gj}Chrnq;#w3@p!4;So=e$o`=K3ZQ5l.^ {LoM.&]d=o:~48ٟ $Р8@%/VB-XC"⾰!Tu7BH.Z闾-L!`^\'4"/Uӭ[DXڢ?lfj:^5puv;vm/3Pxy_~^Oj|>WT[$;b_mR\j!ئ]z DKB< y-.@CNO _:o73waM; lV7>5[!@{CxHBC؍O p? _c6G<N') an U U !}Hڥo6:H{)l #y 8.pNaJatSyO :PYg!$A' pZ ٮ h:MVgC痤 Z{HR|%M\6:0d\OtZKцe;; f7gKVI(( .kf BZԀtAJ!@HUlNY z[ywfs%Gk: >#G!xq¦ij0TCؔg!d<P@E 4Z]MTnp*S mf3   <a={4S/!T 9a\S%a<Ap>{ S]B54NGh\4!2̶`aࣛ4,utpMyLJF@ )ylf3^x\g'idv l+CZpRg_ $1[m~-O* ܼ4"MfaWߠVkIX1JNzpj( Tə x,!@@@@g c`ULQT~ٻ!<%NL: 3q@@P@@P@@P@@PyQ7h0v@>-vw(Bv"2Eӟ~"wI4lڸffp(̴78/QdC@(@pfڷW_l@ >T"jC~x9,UD>DBq!o ?§TAAT@XoIENDB`./version081/tcpippaper/tcp_ip.doc0100777000000000000000000016700007300314370015754 0ustar rootrootࡱ> rtqY kHbjbjWW -==kD] , Jp  $ ~  JX \ Xj: X 6`85  TCP/IP, DEVICE DRIVERS and OOP What is COLDFORTH Colour Vision Systems builds fruit handling equipment. In that market we build vision systems and supply reasonably complex distributed computing systems. The real time computers have always been based on the 68k and FORTH. The systems have been tied together using proprietary communication protocols. Two years ago Motorola brought the 68k family to an end. They announced the 68060 would be the last. We had an OS that was tied to the 68k with over 50% of the code written in 68k assembler. For the first time in 14 years we had to look over the fence and evaluate processor families offered by others, and worry about the OS. We looked hard at the option of abandoning our OS and moving to a commercial solution. Unfortunately our applications require preemptive multitasking so the solutions offered by the major FORTH vendors were not suitable. We evaluated several C based solutions but concluded the development model offered by FORTH had served us well. No one was looking forward to developing their embedded code with emulators and remote debuggers. With our current system a service engineer can go to site and modify the code of the most insignificant embedded processors without any additional equipment. All subsystems are networked and all provide access to the development task, with file services being provided by a central server. We reluctantly decided to rewrite our OS in FORTH, making it as portable as possible.. We also decided to place the result under the GPLL in the hope that others may find a use for the result. Colour Vision Systems are not in the OS business. The decision to write the entire OS in FORTH and the decision to GPLL the code influenced the COLDFORTH design goals. COLDFORTH DESIGN GOALS Move from indirect threaded to subroutine threaded. You have to do this to get the speed required if all the OS is to be written in FORTH. This has been done. Add compiler optimization. Design done, code to be written. Add reasonable heap control, this has been done, and has been described in a separate paper. A well defined structure for drivers. Done and covered briefly in the next section of this paper Move to the ANSI standard, but only if the standard doesnt reduce current functionality. This has been done, we have kept our own local variable standard as it is much more useful than the system described by the ANSI standard. This was covered in a paper I presented last year. All code included in the kernel had to be GPLL-able. I wanted this rule relaxed so the development could move faster, but other principals in the company where adamant that this was not an option. For the OS to be useful in the long term it had to support TCP/IP. This is well on the way and the topic for this paper. Local multi user file support, to be specific, a file system that uses flash to store the data. Done, the file system was modeled on the Minux file system. The code has all been written as HTML files. Making it a simple matter to present it on the web. A CVS server will be put on line in the new year. IO DRIVERS An operating system should provide a framework that ties device drivers together and a structure to manage resources. The two other papers presented this year discussed COLDFORTHs heap allocation and task scheduling, both resource management issues. How COLDFORTH device drivers are implemented heavily influences the COLDFORTH TCP/IP stack and is discussed here. Basically COLDFIRE device drivers are objects and the whole system has been designed around classes. Considerable time was spent evaluating the various OOP models that have been developed for FORTH. We selected Anton Ertls model, modifying it so that cross compile-able code could be written. We also altered word names so they met our coding standards. Having used Antons model extensively we want to make several small changes to it. I am hoping these changes are influenced by a consensus as to what the ANSI standard OOP language should look like. ANSI standard word do not conflict with our coding standard because of rule one. No matter how irrational the ANSI standard word names is; use it. ANSI standard words are in capital letter, non standard names are in lower case. COLDFORTH is case sensitive. There is however one area where we are now very inflexible. Polymorphism and late binding. It has to be fast. Searching for a name match is not an option. THE ANSI WORDS and DEVICE DRIVERS Handling of devices can be broken down to one simple requirement. A single function has to perform the same operation against completely different hardware. The ANSI standard gives the names of suitable function for I/O operation, but no guidance on how the functions are to be implemented. In fact without a bit of lateral thinking you may not see that READ-FILE is a perfectly good word to read data from any I/O device, be it serial or block orientated; local or remote; based on silicon or rotating disk based. The COLDFORTH definition of READ-FILE is: : READ-FILE ( c-addr u1 fileid -- u2 ior ) ['] :read CATCH DUP IF >R 2DROP zero R> THEN ; The definition is simple and it is almost all ANSI forth. The COLDFORTH fileid is the base address of an object. READ-FILE calls the :read method within the object. We have to use CATCH as the COLDFORTH device standard allows the device methods to abort on failure. The READ-FILE description requires an ior code on error. CATCH is an elegant solution. The abort is converted converted to a stack error. CATCH is a terrific idea. Defining methods that have different actions in derived classes is called POLYMORPHISM. For some reason OOP programming has developed a jargon that seems to aim to confuse. Obviously for the READ-FILE code to be efficient, runtime lookup of the :read method has to be fast. This is the case for the OOP program model presented by Anton. All the FORTH I/O words can be built up from methods implemented in the standard COLDFORTH driver. The file words take the object address from the stack. Words such as EXPECT and TYPE take their object address from a user variable. For example the definition of TYPE is: : TYPE ( addr num--) 'output_file @ :type ; output_file is the user variable where the address of the object opened for output is stored. TYPE like the device methods is allowed to ABORT on failure. This leads to a definition that is even cleaner than the definition for READ-FILE. :type is defined for serial devices and block devices, there is only one real difference between TYPE and WRITE-FILE. TYPE takes its object address from a user variable; WRITE-FILE takes it from the stack. open action close All COLDFORTH I/O operations follow the open action close paradigm. Open provides the object address, the operations require the object address and close destroys the object. In all cases the object is created on the heap, and close returns the object to free heap memory. As is common with a lot of COLDFORTH I/O words, Open comes in three flavors: open ( "string" --object) $open ( addr --object) Sopen ( addr n --object) The open string has the form: device/device_string The open function splits the string at the first / and uses the left hand portion to search the device word list. If a word is found in the word list, it is treated as a class and used to construct an object. The construction process is given the address and count of the right portion of the string. For example: To open a file that is stored in flash memory you would use the code: open flash/directory_name/file_name To open a udp client talking to machine 192.168.255.1 port 07 you use the code: open udp_client/192.168.255.1/07 Or if you want to bind to the port and leave the machine specification for later: open udp_client//07 In all case data can be read from the device using READ-FILE. Using classes and polymorphism to tame the TCP/IP jungle. The tcp/ip protocol field is eight bits long, in practice only a few values have meaning; you dont however have to define all valid protocols at kernel compile time. We define the required methods with a base class and derive the different protocols from that class. Dispatching an ip datagram then becomes an exercise in searching created protocol object and presenting the incoming datagram to the right method in the object that handles the selected protocol. Tcp/ip is about accepting datagram from different network interfaces, routing them and passing them onto other network interfaces. The routing routine doesnt get involved in device details; it simply determines which interface should get the datagram; extracts the interface's object address and calls the :consume_interface method through the object, the routing routine doesnt get involved in the messy details. The UDP and TCP protocols requires the source address and destination address to create the protocol checksum, the source address is dependent on the interface over which the datagram is sent, the interface a datagram is sent is dependent on the routing tables. The routing tables are a dynamic data structure. If you use classes and methods the problem is simply solved, you add the protocol object to the data structure describing the datagram and have the interface object call the protocol checksum method just before fragmentation. Classes and polymorphism have been used to break the tcp/ip stack up into well defined sections with clean interfaces. Once again I will mention the basic underlying requirement. Fast runtime binding of objects to methods. A WALK THROUGH THE IP CODE. The routing task. If a packet is placed on the ip queue it will be removed by the routing task. The routing task doesnt have to ask difficult questions or look for exceptions. Its life is simple. Dequeue the ip packet, extract the destination, look up the routing table entry for that destination. Call the :consume_interface method of the object pointed to by the routing table entry found. The routing table entries contain a flag that is true if the entry is for a broadcast address; if it is true the :broadcast method is called instead of the :consume_interface method. The :consume_inerface or :broadcast method will take the packet and deal with it as required. INCLUDEPICTURE \d "./routing_task.png" The interfaces Ip packets enter and exit the tcp/ip code through an interface. Interface_common is the base class. From interface_common we derive interface_local used if the packet is destined for the local machine. Interface_loopback, is used if the packet was sent to the loopback address. interface_nice is used to get packets from and send packets to the ethernet, and interface_rti is used to transfer packets across the rti backplane. Ethernet interface To send a packet from one machine to another on an ethernet link the ip address has to be converted to a hardware address. The tcp/ip standard describes another protocol referred to as arp ( address resolution protocol). The arp protocol is used to request the mapping. The workings of this protocol are contained within the interface_nice class as it has nothing to do with the rest of the system. INCLUDEPICTURE \d "./interface_nice.png" rti interface The ethernet interface is complex as the ip to hardware address translation involves another protocol. The rti_interface uses the low low 4 bits of the ip address to select a card. The rti bus being a sixteen bit bus that supports up to 16 I/O cards. INCLUDEPICTURE \d "./interface_rti.png" Loopback interface The loopback interface is simpler again, it provides the method needed by the routing task to get rid of a loopback packet ( :consume_interface) performs the miscellaneous functions an interface is expected to do, such as filling in the source address and checksumming the protocol. Loopback interface then queues the packet onto the proto_queue. A loopback packet will not be fragmented, so the loopback interface doesn't have to get involved in de-fragmenting. INCLUDEPICTURE \d "./interface_loopback.png" local interface ip packets destined for the local machine will be routed to the local interface. The local interface puts together fragmented datagrams and queues reconstructed datagrams onto the protocol queue. The protocol task takes packets from the protocol queue, looks up the protocol table extracts the address of the object that looks after the selected protocol and executes the :proto_demux method. The difference between the ip_queue and the proto_queue can be summarized with one statement. The ip_queue sees all ip packets seen be the system. The proto_queue sees only those packets that are routed to the local machine. INCLUDEPICTURE \d "./interface_local.png" And the beat goes on The ip packet has arrived, it was destined for the local machine so it ended up on the proto_queue. The protocol task has looked at the protocol field in the ip header searched for a protocol demux table entry for the protocol and called the relevant :prot_demux method. But the beat goes on. In the TCP/IP suit three protocols are significant, ICMP (internet control message protocol), UDP (User datgram protocol) and TCP (Reliable Stream Transport Service). At this level ICMP is the most difficult to deal with. Many of the ICMP messages contain the header of the datagram that caused a problem. The ICMP code has to extract the ip header returned in it's data field, and return an error to the socket that initially sent the datagram. To do this the ICMP code extracts the protocol of the returned datagram, searches the protocol demux table for the protocol and calls the relevant :proto_error method. OOP has once again supplied us with a very elegant solution. INCLUDEPICTURE \d "./icmp_udp_error.png" socket demux Socket demux takes the source ip address, destination ip address, source port and destination port, works out which object would like to deal with the packet and hands it on. The icmp protocol doesnt do a socket demux, both the udp and tcp protocol do. The protocol demux is done in the :proto_demux method or the :proto_error method. The objects consuming the packets are linked into a hash table. The routine searches the hash table for the desired entry and hands the packet to the :consume_port method. For the udp protocol the object that consumes packets demuxed to the socket is the io_common object created when the port is opened. The io_common object adds the packet to the data that can be read using the :read method we introduced at the start of this paper. Tcp packets still have a way to go, the address of the object dealing with the socket is added to the ip data structure, and the packet queued on the tcp_queue, to be dealt with by the tcp task. A look at the OOP model. I have outlined how OOP techniques have been used to tame the tcp/ip stack. I touched on how they where used to create a very elegant structure for device drivers. I could just as easily have discussed how OOP techniques led to a very tidy file system I have only looked at two OOP implementations in detail, Andrew McKewan's and Anton Ertl's. It was my view the FORTH community needed another OOP model like a hole in the head, I therefore tried to adapt what was there to meet our needs. We have developed cross compilers to the point where they could compile code written using either model. So for us this was not an issue. We adopted the Anton's model because of its simplicity. Anton's model An object places the address of a data structure on the stack, nothing more. So the rest of Anton's model doesn't care how the address of the data structure came to be. 'output_file @ Is as valid as: object_name You can create an object in the dictionary, an object on the heap or an object on the stack, and they all behave the same way. The address of an object is returned. Anton's methods take an object from the stack, and locates the method using an offset into the method table. The runtime code is: DOES> _selector_offset+ @ \ object selector_offset<-- OVER _object_map+ @ + \ object xtp<-- @execute ; Blindly using an offset can lead to problems if two different classes have the same method name, but are using different table offsets. It is a hard bug to find. The COLDFORTH kernel makes extensive use of word name checksums ( to be specific the ethernet CRC32 bit checksum), with the compiler insisting that all tokens used generate a unique CRC32 code. Our version of Anton's code checks that the methods CRC32 matches the CRC32 code found at the table offset given. The runtime code becomes: DOES> DUP _crc_offset+ @ >R _selector_offset+ @ \ object selector_offset<-- OVER _object_map+ @ + \ object xtp<-- DUP _object_crc + @ R> = IF @execute EXIT THEN TRUE ABORT" Object didn't contain selected method" ; Yes it is slower, but it is still faster than searching a method list. As one of COLDFORTH's goals is portable code this is it, it has not been converted to assembler. It is possible to replace the ABORT with a table search, this converts the offset into a hint that will speed late binding in most cases. What we have done simply adds a runtime check that the object presented is valid for the method being invoked. Anton's code did allow for compile time binding, I have re-read the source and found an example, the syntax is. [bind] object print Obviously it will only work if the object exists at compile time. We have not used this feature in the kernel. Y_(ADTY!SUa9BDIL]hl   !!!"n""""**x++++++++,,E,F,G,H,,,,,,,jUmHnH jU60J#^1a[~ r 8 v +^ & F@& 1a[~ r 8 v +^ m #9PSU$6 4!!!!"n""ƿ                        uX > m #9PSU$6  v% 4!!!!"n""""$j&(b)~))++,I,X,..///0 11 v%"""$j&(b)~))++,I,X,..///0 1123-3455577h9999<==>o@}@'A7AHAUAA~BBBBBBBDDDE7E_E~EEEEEE{FuGGGkH E,"-4-n-|---[/i///////0011111122333355555566S9_9999999; ;;';<<'A6AHATA~BBDEGGkHjUmHnH0J#j7UmHnHj^UmHnHjUmHnHjUmHnH jU6=123-3455577h9999<==>o@}@'A7AHAUAA~BBBB v%BBBBDDDE7E_E~EEEEEE{FuGGGkH v%+0P/ =!"#$%DfIG"./routing_task.pngh  S D&? ./routing_task.pngDfz6&%*./interface_nice.pngl  S H*? ./interface_nice.pngDf` ./interface_rti.pngj  S F(? ./interface_rti.pngDf8H$ ./interface_loopback.pngt  S P2? ./interface_loopback.pngDfBy./interface_local.pngn   S J,? ./interface_local.pngDf%&tt./icmp_udp_error.pngr   c N*? ./icmp_udp_error.png) [<@<Normal 1$ddCJhmH nH <A@<Default Paragraph Font:O:Definition Term >O>Definition Listh(O( Definition6*O*H1$@& 5CJ0KH$&O&H2$@&5CJ$&O&H3$@&5CJ"O"H4$@&5&O&H5$@&5CJ&O&H6$@&5CJ.O.Address 60O0 Blockquote hhOCITE6$O$CODE CJOJQJ$X@$Emphasis6(U@( Hyperlink>*B*8V@8FollowedHyperlink>*B* 0O0Keyboard5CJOJQJfOf Preformatted0  # ~= z9!v% CJOJQJZOZz-Bottom of Form!$1$$d<CJOJQJhmH nH TOT z-Top of Form"$1$&d<CJOJQJhmH nH $O1$SampleOJQJ W@A Strong50OQ0 Typewriter CJOJQJ$Oa$Variable6,Oq, HTML Markup<B*"O"Comment<kD ?O %Q O O Q P ,  [O Q >IK Q #I ZQ kN QP #$(+ -159>CkD<$,. /  p,kHGM 1BkHHJKNO"kHIL(E(G(+++,--.//111555kDCCCCCC(H(++,-./1155AmDcharleseC:\BCM550\tcpippaper\tcp_ip.doc..p.@ .......p.@ ..... }@jDjDCCjDjDkD@GTimes New Roman5Symbol3& Arial?5 Courier New"hI:fI:f 7v  7v %BB 4CVS FORTH KERNELforth Charles EssoncharleseOh+'0t  0 < HT\dlCVS FORTH KERNELdVS Charles EssonELforths  Normal.doto charleseto2arMicrosoft Word 8.0@@B @B  7՜.+,D՜.+,` px  Colour Vision Systems N vBj CVS FORTH KERNEL TitleT0nv _PID_GUID _PID_HLINKS descriptionAN{CDEE44AD-8A45-11D3-B769-0060083135F2}AD$`F,./routing_task.pnge/./interface_nice.png.J1./interface_rti.png|3./interface_loopback.pngV05 ./interface_local.pngK9 ./icmp_udp_error.png0 COLDFORTH uses this file to generate COLDFORTH  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPRSTUVWXZ[\]^_`bcdefghjklmnopsRoot Entry F@7p{5 uData Q1TableYWordDocument-SummaryInformation(aDocumentSummaryInformation8iCompObjjObjectPool{5 {5   FMicrosoft Word Document MSWordDocWord.Document.89q./version081/tcpippaper/tcp_ip.html0100777000000000000000000004702007300314370016152 0ustar rootroot CVS FORTH KERNEL

TCP/IP, DEVICE DRIVERS and OOP

What is COLDFORTH

Colour Vision Systems builds fruit handling equipment. In that market we build vision systems and supply reasonably complex distributed computing systems. The real time computers have always been based on the 68k and FORTH. The systems have been tied together using proprietary communication protocols.

Two years ago Motorola brought the 68k family to an end. They announced the 68060 would be the last.

We had an OS that was tied to the 68k with over 50% of the code written in 68k assembler. For the first time in 14 years we had to look over the fence and evaluate processor families offered by others, and worry about the OS.

We looked hard at the option of abandoning our OS and moving to a commercial solution. Unfortunately our applications require preemptive multitasking so the solutions offered by the major FORTH vendors were not suitable.

We evaluated several C based solutions but concluded the development model offered by FORTH had served us well. No one was looking forward to developing their embedded code with emulators and remote debuggers.

With our current system a service engineer can go to site and modify the code of the most insignificant embedded processors without any additional equipment. All subsystems are networked and all provide access to the development task, with file services being provided by a central server.

We reluctantly decided to rewrite our OS in FORTH, making it as portable as possible.. We also decided to place the result under the GPLL in the hope that others may find a use for the result. Colour Vision Systems are not in the OS business.

The decision to write the entire OS in FORTH and the decision to GPLL the code influenced the COLDFORTH design goals.

COLDFORTH DESIGN GOALS

  1. Move from indirect threaded to subroutine threaded. You have to do this to get the speed required if all the OS is to be written in FORTH. This has been done.
  2. Add compiler optimization. Design done, code to be written.
  3. Add reasonable heap control, this has been done, and has been described in a separate paper.
  4. A well defined structure for drivers. Done and covered briefly in the next section of this paper
  5. Move to the ANSI standard, but only if the standard doesnt reduce current functionality. This has been done, we have kept our own local variable standard as it is much more useful than the system described by the ANSI standard. This was covered in a paper I presented last year.
  6. All code included in the kernel had to be GPLL-able. I wanted this rule relaxed so the development could move faster, but other principals in the company where adamant that this was not an option.
  7. For the OS to be useful in the long term it had to support TCP/IP. This is well on the way and the topic for this paper.
  8. Local multi user file support, to be specific, a file system that uses flash to store the data. Done, the file system was modeled on the Minux file system.

The code has all been written as HTML files. Making it a simple matter to present it on the web. A CVS server will be put on line in the new year.

IO DRIVERS

An operating system should provide a framework that ties device drivers together and a structure to manage resources.

The two other papers presented this year discussed COLDFORTHs heap allocation and task scheduling, both resource management issues. How COLDFORTH device drivers are implemented heavily influences the COLDFORTH TCP/IP stack and is discussed here.

Basically COLDFIRE device drivers are objects and the whole system has been designed around classes. Considerable time was spent evaluating the various OOP models that have been developed for FORTH. We selected Anton Ertls model, modifying it so that cross compile-able code could be written. We also altered word names so they met our coding standards.

Having used Antons model extensively we want to make several small changes to it. I am hoping these changes are influenced by a consensus as to what the ANSI standard OOP language should look like. ANSI standard word do not conflict with our coding standard because of rule one. No matter how irrational the ANSI standard word names is; use it. ANSI standard words are in capital letter, non standard names are in lower case. COLDFORTH is case sensitive.

There is however one area where we are now very inflexible. Polymorphism and late binding. It has to be fast. Searching for a name match is not an option.

THE ANSI WORDS and DEVICE DRIVERS

Handling of devices can be broken down to one simple requirement. A single function has to perform the same operation against completely different hardware. The ANSI standard gives the names of suitable function for I/O operation, but no guidance on how the functions are to be implemented. In fact without a bit of lateral thinking you may not see that READ-FILE is a perfectly good word to read data from any I/O device, be it serial or block orientated; local or remote; based on silicon or rotating disk based.

The COLDFORTH definition of READ-FILE is:

	: READ-FILE ( c-addr u1 fileid -- u2 ior )
		['] :read CATCH DUP IF
		>R 2DROP zero R>
		THEN
	;

The definition is simple and it is almost all ANSI forth. The COLDFORTH fileid is the base address of an object. READ-FILE calls the :read method within the object. We have to use CATCH as the COLDFORTH device standard allows the device methods to abort on failure. The READ-FILE description requires an ior code on error. CATCH is an elegant solution. The abort is converted converted to a stack error. CATCH is a terrific idea.

Defining methods that have different actions in derived classes is called POLYMORPHISM. For some reason OOP programming has developed a jargon that seems to aim to confuse.

Obviously for the READ-FILE code to be efficient, runtime lookup of the :read method has to be fast. This is the case for the OOP program model presented by Anton.

All the FORTH I/O words can be built up from methods implemented in the standard COLDFORTH driver. The file words take the object address from the stack. Words such as EXPECT and TYPE take their object address from a user variable. For example the definition of TYPE is:

  
	: TYPE ( addr num--)
		'output_file @ :type
	;

output_file is the user variable where the address of the object opened for output is stored. TYPE like the device methods is allowed to ABORT on failure. This leads to a definition that is even cleaner than the definition for READ-FILE. :type is defined for serial devices and block devices, there is only one real difference between TYPE and WRITE-FILE. TYPE takes its object address from a user variable; WRITE-FILE takes it from the stack.

open action close

All COLDFORTH I/O operations follow the open action close paradigm. Open provides the object address, the operations require the object address and close destroys the object. In all cases the object is created on the heap, and close returns the object to free heap memory.

As is common with a lot of COLDFORTH I/O words, Open comes in three flavors:

 
	open ( "string" --object)
	$open ( addr --object)
	Sopen ( addr n --object)

The open string has the form:

device/device_string

The open function splits the string at the first / and uses the left hand portion to search the device word list. If a word is found in the word list, it is treated as a class and used to construct an object. The construction process is given the address and count of the right portion of the string.

For example: To open a file that is stored in flash memory you would use the code:

open flash/directory_name/file_name

To open a udp client talking to machine 192.168.255.1 port 07 you use the code:

open udp_client/192.168.255.1/07

Or if you want to bind to the port and leave the machine specification for later:

open udp_client//07

In all case data can be read from the device using READ-FILE.

Using classes and polymorphism to tame the TCP/IP jungle.

The tcp/ip protocol field is eight bits long, in practice only a few values have meaning; you dont however have to define all valid protocols at kernel compile time. We define the required methods with a base class and derive the different protocols from that class. Dispatching an ip datagram then becomes an exercise in searching created protocol object and presenting the incoming datagram to the right method in the object that handles the selected protocol.

Tcp/ip is about accepting datagram from different network interfaces, routing them and passing them onto other network interfaces. The routing routine doesnt get involved in device details; it simply determines which interface should get the datagram; extracts the interface's object address and calls the :consume_interface method through the object, the routing routine doesnt get involved in the messy details.

The UDP and TCP protocols requires the source address and destination address to create the protocol checksum, the source address is dependent on the interface over which the datagram is sent, the interface a datagram is sent is dependent on the routing tables. The routing tables are a dynamic data structure. If you use classes and methods the problem is simply solved, you add the protocol object to the data structure describing the datagram and have the interface object call the protocol checksum method just before fragmentation.

Classes and polymorphism have been used to break the tcp/ip stack up into well defined sections with clean interfaces. Once again I will mention the basic underlying requirement. Fast runtime binding of objects to methods.

A WALK THROUGH THE IP CODE.

The routing task.

If a packet is placed on the ip queue it will be removed by the routing task. The routing task doesnt have to ask difficult questions or look for exceptions. Its life is simple. Dequeue the ip packet, extract the destination, look up the routing table entry for that destination. Call the :consume_interface method of the object pointed to by the routing table entry found.

The routing table entries contain a flag that is true if the entry is for a broadcast address; if it is true the :broadcast method is called instead of the :consume_interface method.

The :consume_inerface or :broadcast method will take the packet and deal with it as required.

The interfaces

Ip packets enter and exit the tcp/ip code through an interface. Interface_common is the base class. From interface_common we derive interface_local used if the packet is destined for the local machine. Interface_loopback, is used if the packet was sent to the loopback address. interface_nice is used to get packets from and send packets to the ethernet, and interface_rti is used to transfer packets across the rti backplane.

Ethernet interface

To send a packet from one machine to another on an ethernet link the ip address has to be converted to a hardware address. The tcp/ip standard describes another protocol referred to as arp ( address resolution protocol). The arp protocol is used to request the mapping. The workings of this protocol are contained within the interface_nice class as it has nothing to do with the rest of the system.

rti interface

The ethernet interface is complex as the ip to hardware address translation involves another protocol. The rti_interface uses the low low 4 bits of the ip address to select a card. The rti bus being a sixteen bit bus that supports up to 16 I/O cards.

Loopback interface

The loopback interface is simpler again, it provides the method needed by the routing task to get rid of a loopback packet ( :consume_interface) performs the miscellaneous functions an interface is expected to do, such as filling in the source address and checksumming the protocol. Loopback interface then queues the packet onto the proto_queue. A loopback packet will not be fragmented, so the loopback interface doesn't have to get involved in de-fragmenting.

local interface

ip packets destined for the local machine will be routed to the local interface. The local interface puts together fragmented datagrams and queues reconstructed datagrams onto the protocol queue. The protocol task takes packets from the protocol queue, looks up the protocol table extracts the address of the object that looks after the selected protocol and executes the :proto_demux method.

The difference between the ip_queue and the proto_queue can be summarized with one statement. The ip_queue sees all ip packets seen be the system. The proto_queue sees only those packets that are routed to the local machine.

And the beat goes on

The ip packet has arrived, it was destined for the local machine so it ended up on the proto_queue. The protocol task has looked at the protocol field in the ip header searched for a protocol demux table entry for the protocol and called the relevant :prot_demux method. But the beat goes on.

In the TCP/IP suit three protocols are significant, ICMP (internet control message protocol), UDP (User datgram protocol) and TCP (Reliable Stream Transport Service).

At this level ICMP is the most difficult to deal with. Many of the ICMP messages contain the header of the datagram that caused a problem. The ICMP code has to extract the ip header returned in it's data field, and return an error to the socket that initially sent the datagram. To do this the ICMP code extracts the protocol of the returned datagram, searches the protocol demux table for the protocol and calls the relevant :proto_error method.

OOP has once again supplied us with a very elegant solution.

socket demux

Socket demux takes the source ip address, destination ip address, source port and destination port, works out which object would like to deal with the packet and hands it on. The icmp protocol doesnt do a socket demux, both the udp and tcp protocol do. The protocol demux is done in the :proto_demux method or the :proto_error method. The objects consuming the packets are linked into a hash table. The routine searches the hash table for the desired entry and hands the packet to the :consume_port method. For the udp protocol the object that consumes packets demuxed to the socket is the io_common object created when the port is opened. The io_common object adds the packet to the data that can be read using the :read method we introduced at the start of this paper.

Tcp packets still have a way to go, the address of the object dealing with the socket is added to the ip data structure, and the packet queued on the tcp_queue, to be dealt with by the tcp task.

A look at the OOP model.

I have outlined how OOP techniques have been used to tame the tcp/ip stack. I touched on how they where used to create a very elegant structure for device drivers. I could just as easily have discussed how OOP techniques led to a very tidy file system

I have only looked at two OOP implementations in detail, Andrew McKewan's and Anton Ertl's. It was my view the FORTH community needed another OOP model like a hole in the head, I therefore tried to adapt what was there to meet our needs. We have developed cross compilers to the point where they could compile code written using either model. So for us this was not an issue. We adopted the Anton's model because of its simplicity.

Anton's model

An object places the address of a data structure on the stack, nothing more. So the rest of Anton's model doesn't care how the address of the data structure came to be.

'output_file @

Is as valid as:

object_name

You can create an object in the dictionary, an object on the heap or an object on the stack, and they all behave the same way. The address of an object is returned.

Anton's methods take an object from the stack, and locates the method using an offset into the method table. The runtime code is: 


	DOES>
		_selector_offset+ @   \ object selector_offset<--
		OVER _object_map+ @ + \ object xtp<-- 
		@execute
	;

Blindly using an offset can lead to problems if two different classes have the same method name, but are using different table offsets. It is a hard bug to find. The COLDFORTH kernel makes extensive use of word name checksums ( to be specific the ethernet CRC32 bit checksum), with the compiler insisting that all tokens used generate a unique CRC32 code. Our version of Anton's code checks that the methods CRC32 matches the CRC32 code found at the table offset given. The runtime code becomes:


	DOES>
		DUP _crc_offset+  @ >R
		_selector_offset+ @   \ object selector_offset<--
		OVER _object_map+ @ + \ object xtp<--
		DUP _object_crc  + @ R> = IF
			@execute
			EXIT
		THEN
		TRUE ABORT" Object didn't contain selected method" 
	;

Yes it is slower, but it is still faster than searching a method list. As one of COLDFORTH's goals is portable code this is it, it has not been converted to assembler.

It is possible to replace the ABORT with a table search, this converts the offset into a hint that will speed late binding in most cases. What we have done simply adds a runtime check that the object presented is valid for the method being invoked.

Anton's code did allow for compile time binding, I have re-read the source and found an example, the syntax is.

[bind] object print

Obviously it will only work if the object exists at compile time. We have not used this feature in the kernel.

./version081/tcpippaper/tcp_ip_slides.doc0100777000000000000000000012400007300314371017311 0ustar rootrootࡱ> OQNY 7bjbjWW -P==3]nnnnnnn,pNNNNNNN$~nNNNNN( nnNN( ( ( NnNnNnnnnN( &( N:dXnnN^ho0(  COLDFORTH DESIGN GOALS Write as much as possible in FORTH. Move from indirect threaded to subroutine threaded. Add compiler optimization. Add reasonable heap control A well defined structure for I/O drivers. Move towards the ANSI standard. All code included in the kernel had to be GPLL-able Support TCP/IP Local multi user file support, to be specific, a file system that uses flash to store the data. Write the code as HTML files. Making it a simple matter to present it on the web. IO DRIVERS An operating system should provide a framework that ties device drivers together and a structure to manage resources. COLDFIRE device drivers are objects and the whole system has been designed around classes. We selected Anton model, modifying it so that cross compile-able code could be written. Having used Antons model extensively we want to make several small changes to it. I am hoping these changes are influenced by a consensus as to what the ANSI standard OOP language should look like. There is however one area where we are now very inflexible. Polymorphism and late binding. It has to be fast. Searching for a name match is not an option. THE ANSI WORDS and DEVICE DRIVERS Handling of devices can be broken down to one simple requirement. A single function has to perform the same operation against completely different hardware. The ANSI standard gives the names of suitable function for I/O operation, but no guidance on how the functions are to be implemented. READ-FILE is a perfectly good word to read data from any I/O device, be it serial or block orientated; local or remote; based on silicon or rotating disk based. The COLDFORTH definition of READ-FILE is: : READ-FILE ( c-addr u1 fileid -- u2 ior ) ['] :read CATCH DUP IF >R 2DROP zero R> THEN ; The COLDFORTH fileid is the base address of an object. READ-FILE calls the :read method within the object. We have to use CATCH as the COLDFORTH device standard allows the device methods to abort on failure. The READ-FILE description requires an ior code on error. CATCH is an elegant solution. The abort is converted to a stack error. Obviously for the READ-FILE code to be efficient, runtime lookup of the :read method has to be fast. This is the case for the OOP program model presented by Anton. FORTH I/O All the FORTH I/O words can be built up from methods implemented in the standard COLDFORTH driver. The file words take the object address from the stack. Words such as EXPECT and TYPE take their object address from a user variable. For example the definition of TYPE is: : TYPE ( addr num--) 'output_file @ :type ; output_file is the user variable where the address of the object opened for output is stored. TYPE like the device methods is allowed to ABORT on failure. This leads to a definition that is even cleaner than the definition for READ-FILE. :type is defined for serial devices and block devices, there is only one real difference between TYPE and WRITE-FILE. TYPE takes its object address from a user variable; WRITE-FILE takes it from the stack. open action close All COLDFORTH I/O operations follow the open action close paradigm. Open provides the object address, the operations require the object address and close destroys the object. In all cases the object is created on the heap, and close returns the object to free heap memory. As is common with a lot of COLDFORTH I/O words, Open comes in three flavors: open ( "string" --object) $open ( addr --object) Sopen ( addr n --object) The open string has the form: device/device_string The open function splits the string at the first / and uses the left hand portion to search the device word list. If a word is found in the word list, it is treated as a class and used to construct an object. The construction process is given the address and count of the right portion of the string. EXAMPLES To open a file that is stored in flash memory you would use the code: open flash/directory_name/file_name To open a udp client talking to machine 192.168.255.1 port 07 you use the code: open udp_client/192.168.255.1/07 Or if you want to bind to the port and leave the machine specification for later: open udp_client//07 In all case data can be read from the device using READ-FILE. Using classes and polymorphism to tame the TCP/IP jungle. The tcp/ip protocol field is eight bits long, in practice only a few values have meaning; you dont however have to define all valid protocols at kernel compile time. We define the required methods with a base class and derive the different protocols from that class. Dispatching an ip datagram then becomes an exercise in searching created protocol object and presenting the incoming datagram to a method in the object that handles the selected protocol. Tcp/ip is about accepting datagram from different network interfaces, routing them and passing them onto other network interfaces. The routing routine doesnt get involved in device details; it simply determines which interface should get the datagram; extracts the interface's object address and calls the :consume_interface method through the object, the routing routine doesnt get involved in the messy details. The UDP and TCP protocols requires the source address and destination address to create the protocol checksum, the source address is dependent on the interface over which the datagram is sent, the interface a datagram is sent to is dependent on the routing tables. The routing tables are a dynamic data structure. If you use classes and methods the problem is simply solved, you add the protocol object to the data structure describing the datagram and have the interface object call the protocol checksum method just before fragmentation. Classes and polymorphism have been used to break the tcp/ip stack up into well defined sections with clean interfaces. Once again I will mention the basic underlying requirement. Fast runtime binding of objects to methods. A WALK THROUGH THE IP CODE. The routing task. If a packet is placed on the ip queue it will be removed by the routing task. The routing task doesnt have to ask difficult questions or look for exceptions. Its life is simple. Dequeue the ip packet, extract the destination, look up the routing table entry for that destination. Call the relevant method of the object pointed to by the routing table entry found. The routing table entries contain a flag that is true if the entry is for a broadcast address; if it is true the :broadcast method is called, if not, the :consume_interface method is called. The :consume_inerface or :broadcast method will take the packet and deal with it as required. INCLUDEPICTURE \d "./routing_task.png" The interfaces Ip packets enter and exit the tcp/ip code through an interface. Interface_common is the base class. From interface_common we derive interface_local used if the packet is destined for the local machine. Interface_loopback, is used if the packet was sent to the loopback address. interface_nice is used to get packets from and send packets to the ethernet, and interface_rti is used to transfer packets across the rti backplane. Ethernet interface To send a packet from one machine to another on an ethernet link the ip address has to be converted to a hardware address. The tcp/ip standard describes another protocol referred to as arp ( address resolution protocol). The arp protocol is used to request the mapping. The workings of this protocol are contained within the interface_nice class as it has nothing to do with the rest of the system. INCLUDEPICTURE \d "./interface_nice.png" rti interface The ethernet interface is complex as the ip to hardware address translation involves another protocol. The rti_interface uses the low low 4 bits of the ip address to select a card. The rti bus being a sixteen bit bus that supports up to 16 I/O cards. INCLUDEPICTURE \d "./interface_rti.png" Loopback interface The loopback interface is simpler again, it provides the method needed by the routing task to get rid of a loopback packet ( :consume_interface) performs the miscellaneous functions an interface is expected to do, such as filling in the source address and checksumming the protocol. Loopback interface then queues the packet onto the proto_queue. A loopback packet will not be fragmented, so the loopback interface doesn't have to get involved in de-fragmenting. INCLUDEPICTURE \d "./interface_loopback.png" local interface ip packets destined for the local machine will be routed to the local interface. The local interface puts together fragmented datagrams and queues reconstructed datagrams onto the protocol queue. The protocol task takes packets from the protocol queue, looks up the protocol table extracts the address of the object that looks after the selected protocol and executes the :proto_demux method. The difference between the ip_queue and the proto_queue can be summarized with one statement. The ip_queue sees all ip packets seen be the system. The proto_queue sees only those packets that are routed to the local machine. INCLUDEPICTURE \d "./interface_local.png" And the beat goes on The ip packet has arrived, it was destined for the local machine so it ended up on the proto_queue. The protocol task has looked at the protocol field in the ip header searched for a protocol demux table entry for the protocol and called the relevant :prot_demux method. But the beat goes on. In the TCP/IP suit three protocols are significant, ICMP (internet control message protocol), UDP (User datgram protocol) and TCP (Reliable Stream Transport Service). At this level ICMP is the most difficult to deal with. Many of the ICMP messages contain the header of the datagram that caused a problem. The ICMP code has to extract the ip header returned in it's data field, and return an error to the socket that initially sent the datagram. To do this the ICMP code extracts the protocol of the returned datagram, searches the protocol demux table for the protocol and calls the relevant :proto_error method. OOP has once again supplied us with a very elegant solution. INCLUDEPICTURE \d "./icmp_udp_error.png" socket demux Socket demux takes the source ip address, destination ip address, source port and destination port, works out which object would like to deal with the packet and hands it on. The icmp protocol doesnt do a socket demux, both the udp and tcp protocol do. The protocol demux is done in the :proto_demux method or the :proto_error method. The objects consuming the packets are linked into a hash table. The routine searches the hash table for the desired entry and hands the packet to the :consume_port method. For both udp and tcp protocol the object that consumes packets demuxed to the socket is the io_common object created when the port is opened. The udp :consume_port method adds the packet to the data that can be read using the :read method we introduced at the start of this paper. Tcp packets still have a way to go, the :consume_port methods adds incoming data to the receive_queue, and removes data acknowledged from the transmit_queue.  A look at the OOP model. I have outlined how OOP techniques have been used to tame the tcp/ip stack. I touched on how they where used to create a very elegant structure for device drivers. I could just as easily have discussed how OOP techniques led to a very tidy file system CVS have only looked at two OOP implementations in detail, Andrew McKewan's and Anton Ertl's. We tried to adapt what was there to meet our needs. We have developed cross compilers to the point where they could compile code written using either model. So for us this was not an issue. We adopted the Anton's model because of its simplicity. ANTONS MODEL An object places the address of a data structure on the stack, nothing more. So the rest of Anton's model doesn't care how the address of the data structure came to be. 'output_file @ Is as valid as: object_name You can create an object in the dictionary, an object on the heap or an object on the stack, and they all behave the same way. The address of an object is returned. Anton's methods take an object from the stack, and locates the method using an offset into the method table. The runtime code is: DOES> _selector_offset+ @ \ object selector_offset<-- OVER _object_map+ @ + \ object xtp<-- @execute ; RUN TIME CHECK Blindly using an offset can lead to problems if two different classes have the same method name, but are using different table offsets. It is a hard bug to find. The COLDFORTH kernel makes extensive use of word name checksums ( to be specific the ethernet CRC32 bit checksum), with the compiler insisting that all tokens used generate a unique CRC32 code. Our version of Anton's code checks that the methods CRC32 matches the CRC32 code found at the table offset given. The runtime code becomes: DOES> DUP _crc_offset+ @ >R _selector_offset+ @ \ object selector_offset<-- OVER _object_map+ @ + \ object xtp<-- DUP _object_crc + @ R> = IF @execute EXIT THEN TRUE ABORT" Object didn't contain method" ; m  3 < F L w |  ` i   ?@BN&/16:KVZ|r"+qXk5 0J#5CJ 6CJ 0J#CJ 5CJ CJCJ Z;p'6m"F o  v%$@& *$@& & F@& ;p'6m"F o h N %<?@B$qs"+qXlMiHew)                           F h N %<?@B$qs"+ v%+qXlMiHew/?!!!""#) v%*HIU_+,-.0 UcB!P!!!!!!!!!!"""""""###$$%%%%%%'''''''(jOUmHnHjpUmHnH6CJCJjUmHnHjCJ UmHnH jCJ U6CJ jUmHnH jU0J#CJ CJ E/?!!!""#$%%&'''()R++++.///01$22222$4%4,4E4c4444466666797E7M7T7\7777 ):#$%%&'''()R++++.///01$22222$4%4,4E4 v%)((=+I+++++++++,,--..////2222$444467770J#5CJ 5 jCJ U0J#CJ CJ 5CJj%CJUmHnH jCJUCJ0J#CJ!E4c4444466666797E7M7T7\7777$@& ) v%+0P/ =!"#$%DfIG"./routing_task.pngn  c J&? ./routing_task.pngDfz6&%*./interface_nice.pngr  c N*? ./interface_nice.pngDf` ./interface_rti.pngp  c L(? ./interface_rti.pngDf8H$ ./interface_loopback.pngz  c V2? ./interface_loopback.pngDfBy./interface_local.pngt  c P,? ./interface_local.pngDf%&tt./icmp_udp_error.pngr  c N*? ./icmp_udp_error.png DdAiX  c 4Atcp.pngb XOhC {q < n XOhC {qPNG  IHDRAf0PLTE{ $IDATx E ]A@Tpjėkp C $CTAATAg!a S 0Ol6_c4DL/JCe4=gaec!0ڭGAܦ$>ϷT0C ٖJ W_Sx4 ^;PQ; ?i0,\8B]7  !}oE Bv3r[:KJ4,`3p ȱ!JvP':W5:Fas:ذ߇> L$iJ!ii܏N On#u”Ov|D;t * CD:~FkgBƗC8    z@@P@@P@ \lVBkW>CAh&  B+HLJP@’F+` fF2 945Aķ ' lB  {sX,K[DoM%:zkuBn? aE;D7j0 ؏—̀@ \4r@p>*@x5zf3    ͍e$Df>z@@@@@@!SSw[+\7<[i@7-&v gj}Chrnq;#w3@p!4;So=e$o`=K3ZQ5l.^ {LoM.&]d=o:~48ٟ $Р8@%/VB-XC"⾰!Tu7BH.Z闾-L!`^\'4"/Uӭ[DXڢ?lfj:^5puv;vm/3Pxy_~^Oj|>WT[$;b_mR\j!ئ]z DKB< y-.@CNO _:o73waM; lV7>5[!@{CxHBC؍O p? _c6G<N') an U U !}Hڥo6:H{)l #y 8.pNaJatSyO :PYg!$A' pZ ٮ h:MVgC痤 Z{HR|%M\6:0d\OtZKцe;; f7gKVI(( .kf BZԀtAJ!@HUlNY z[ywfs%Gk: >#G!xq¦ij0TCؔg!d<P@E 4Z]MTnp*S mf3   <a={4S/!T 9a\S%a<Ap>{ S]B54NGh\4!2̶`aࣛ4,utpMyLJF@ )ylf3^x\g'idv l+CZpRg_ $1[m~-O* ܼ4"MfaWߠVkIX1JNzpj( Tə x,!@@@@g c`ULQT~ٻ!<%NL: 3q@@P@@P@@P@@PyQ7h0v@>-vw(Bv"2Eӟ~"wI4lڸffp(̴78/QdC@(@pfڷW_l@ >T"jC~x9,UD>DBq!o ?§TAAT@XoIENDB`+ [<@<Normal 1$ddCJhmH nH 0`0 Heading 1$@&CJ 4`4 Heading 2$@&5CJ <A@<Default Paragraph Font:O:Definition Term >O>Definition Listh(O( Definition6*O*H1$@& 5CJ0KH$&O&H2$@&5CJ$&O&H3$@&5CJ"O"H4$@&5&O&H5$@&5CJ&O&H6$@&5CJ.O.Address 60O0 Blockquote hhOCITE6$O$CODE CJOJQJ$X@$Emphasis6(U@( Hyperlink>*B*8V@8FollowedHyperlink>*B* 0O0Keyboard5CJOJQJfOf Preformatted0  # ~= z9!v% CJOJQJZOZz-Bottom of Form!$1$$d<CJOJQJhmH nH TOT z-Top of Form"$1$&d<CJOJQJhmH nH $O1$SampleOJQJ W@A Strong50OQ0 Typewriter CJOJQJ$Oa$Variable6,Oq, HTML Markup<B*"O"Comment<*B`* Body Text)CJ.P`. Body Text 2*CJ 3 P (7#& +#E47!"%'7 $+- !!###'''3CCCCCC.5    ! ( 3 C N |?A]`ac CKUc08BD|BP4AORacow   ' R ] a i !!""""""# ###6#A###$'$c$e$$$$$S%Z%?&A& ''>'I'''''''((~(((((((((((())))))))**$*-*[*^*`*l*** ++:+G+p+~+++++,,,,,,--......///0?0P0_0k0v000112%22222222333!3+33charlese&C:\BCM550\tcpippaper\tcp_ip_slides.doccharlese.C:\TEMP\AutoRecovery save of tcp_ip_slides.asdcharlese.C:\TEMP\AutoRecovery save of tcp_ip_slides.asdcharlese&C:\BCM550\tcpippaper\tcp_ip_slides.doccharlese.C:\TEMP\AutoRecovery save of tcp_ip_slides.asdcharlese.C:\TEMP\AutoRecovery save of tcp_ip_slides.asdcharlese.C:\TEMP\AutoRecovery save of tcp_ip_slides.asdcharlese&C:\BCM550\tcpippaper\tcp_ip_slides.doccharlese.C:\TEMP\AutoRecovery save of tcp_ip_slides.asdcharlese&C:\BCM550\tcpippaper\tcp_ip_slides.doc..p.@ .......p.@ .....@#.#.d#.-3@GTimes New Roman5Symbol3& Arial?5 Courier New"Ahe;f;f;fHt~*Z 7v$d.4HACVS FORTH KERNELforth Charles EssoncharleseOh+'0  8 D P \hpxCVS FORTH KERNELdVS Charles EssonELforths  Normal.doto charleseto5arMicrosoft Word 8.0@ @@?)0@Ά0@M0t~*՜.+,D՜.+,` px  Colour Vision Systems NZ.4j CVS FORTH KERNEL Title0nv^ _PID_GUID _PID_HLINKS descriptionAN{CDEE44AD-8A45-11D3-B769-0060083135F2}A*`,./routing_task.pnge!./interface_nice.png.J"./interface_rti.png|%./interface_loopback.pngV0'./interface_local.pngK+./icmp_udp_error.pngt#/tcp.png0 COLDFORTH uses this file to generate COLDFORTH  !"#$%&'(*+,-./023456789:;<=?@ABCDEGHIJKLMPRoot Entry FQ,0to0RData )1Table1iWordDocument-PSummaryInformation(>DocumentSummaryInformation8FCompObjjObjectPoolto0to0  FMicrosoft Word Document MSWordDocWord.Document.89q./version081/test_code/0040700000000000000000000000000007300314371013570 5ustar rootroot./version081/test_code/benchmarks.html0100777000000000000000000000375307300314371016621 0ustar rootroot COLDFORTH KERNEL 
 
=====================================================================
FORTH, INC. target test benchmarks

Copyright (c) 1972-1999, FORTH, Inc.

 These simple benchmarks are used for comparisons for FORTH, Inc. kernel
 implementations.  Execute BENCH to run all of them.  Timing is only as
 accurate as the granularity of the target's millisecond counter.
 
 Requires: COUNTER and TIMER

 Exports: BENCH
===================================================================== 

 

\ xclock+ is updated every reschudule, that is every 10 mesec
\ execute 100 times more often instead of setting up hardware time
              
\ As they have the + running faster than the DO LOOP time I assume they 
\ take the do loop time off to generate the actual time.
\ Thats fair enough.


: COUNTER xclock+ @ ;
: TIMER xclock+ @ SWAP - . ;


: .DO   ." DO "  COUNTER  #1000000 0 DO  I DROP  LOOP  TIMER ;

: .*   ." * "  COUNTER    #1000000 0 DO  I I * DROP  LOOP  TIMER ;

: ./   ." / "  COUNTER    #1000001 1 DO  1000 I / DROP  LOOP  TIMER ;

: .+   ." + "  COUNTER    #1000001 1 DO  1000 I + DROP  LOOP  TIMER ;

: .M*   ." M* " COUNTER   #1000000 0 DO  I I M* 2DROP  LOOP  TIMER ;

: ./MOD   ." /MOD "  COUNTER  #1000001 1 DO  1000 I /MOD  2DROP  LOOP TIMER ;

: .UM/MOD   ." UM/MOD "  COUNTER  #1000001 1 DO  1000 0 I UM/MOD 2DROP  LOOP  TIMER ;

: .D+   ." D+ "  COUNTER  #1000001 1 DO  100000 0 I 0 D+ 2DROP LOOP  TIMER ;

: .*/   ." */ "  COUNTER  #1000001 1 DO  I I I */ DROP  LOOP TIMER ;

: .PAUSE   ." xpause "  COUNTER  #1000000 0 DO  xpause  LOOP  TIMER ;

: BENCH   .DO .* ./ .+ .M* ./MOD .UM/MOD .D+ .*/ .PAUSE ;
./version081/test_code/coretest.4th0100777000000000000000000006373507300314371016075 0ustar rootroot\ From: John Hayes S1I \ Subject: core.fr \ Date: Mon, 27 Nov 95 13:10 HEX \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. \ VERSION 1.2 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... MARKER empty TESTING CORE WORDS \ ------------------------------------------------------------------------ TESTING BASIC ASSUMPTIONS { -> } \ START WITH CLEAN SLATE ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) { : BITSSET? IF 0 0 ELSE 0 THEN ; -> } { 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR ) { 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT ) { -1 BITSSET? -> 0 0 } \ ------------------------------------------------------------------------ TESTING BOOLEANS: INVERT AND OR XOR { 0 0 AND -> 0 } { 0 1 AND -> 0 } { 1 0 AND -> 0 } { 1 1 AND -> 1 } { 0 INVERT 1 AND -> 1 } { 1 INVERT 1 AND -> 0 } 0 CONSTANT 0S 0 INVERT CONSTANT 1S { 0S INVERT -> 1S } { 1S INVERT -> 0S } { 0S 0S AND -> 0S } { 0S 1S AND -> 0S } { 1S 0S AND -> 0S } { 1S 1S AND -> 1S } { 0S 0S OR -> 0S } { 0S 1S OR -> 1S } { 1S 0S OR -> 1S } { 1S 1S OR -> 1S } { 0S 0S XOR -> 0S } { 0S 1S XOR -> 1S } { 1S 0S XOR -> 1S } { 1S 1S XOR -> 0S } \ ------------------------------------------------------------------------ TESTING 2* 2/ LSHIFT RSHIFT ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 1S 1 RSHIFT INVERT CONSTANT MSB { MSB BITSSET? -> 0 0 } { 0S 2* -> 0S } { 1 2* -> 2 } { 4000 2* -> 8000 } { 1S 2* 1 XOR -> 1S } { MSB 2* -> 0S } { 0S 2/ -> 0S } { 1 2/ -> 0 } { 4000 2/ -> 2000 } { 1S 2/ -> 1S } \ MSB PROPOGATED { 1S 1 XOR 2/ -> 1S } { MSB 2/ MSB AND -> MSB } { 1 0 LSHIFT -> 1 } { 1 1 LSHIFT -> 2 } { 1 2 LSHIFT -> 4 } { 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT { 1S 1 LSHIFT 1 XOR -> 1S } { MSB 1 LSHIFT -> 0 } { 1 0 RSHIFT -> 1 } { 1 1 RSHIFT -> 0 } { 2 1 RSHIFT -> 1 } { 4 2 RSHIFT -> 1 } { 8000 F RSHIFT -> 1 } \ BIGGEST { MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS { MSB 1 RSHIFT 2* -> MSB } \ ------------------------------------------------------------------------ TESTING COMPARISONS: 0= = 0< < > U< MIN MAX 0 INVERT CONSTANT MAX-UINT 0 INVERT 1 RSHIFT CONSTANT MAX-INT 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 0 INVERT 1 RSHIFT CONSTANT MID-UINT 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 0S CONSTANT 1S CONSTANT { 0 0= -> } { 1 0= -> } { 2 0= -> } { -1 0= -> } { MAX-UINT 0= -> } { MIN-INT 0= -> } { MAX-INT 0= -> } { 0 0 = -> } { 1 1 = -> } { -1 -1 = -> } { 1 0 = -> } { -1 0 = -> } { 0 1 = -> } { 0 -1 = -> } { 0 0< -> } { -1 0< -> } { MIN-INT 0< -> } { 1 0< -> } { MAX-INT 0< -> } { 0 1 < -> } { 1 2 < -> } { -1 0 < -> } { -1 1 < -> } { MIN-INT 0 < -> } { MIN-INT MAX-INT < -> } { 0 MAX-INT < -> } { 0 0 < -> } { 1 1 < -> } { 1 0 < -> } { 2 1 < -> } { 0 -1 < -> } { 1 -1 < -> } { 0 MIN-INT < -> } { MAX-INT MIN-INT < -> } { MAX-INT 0 < -> } { 0 1 > -> } { 1 2 > -> } { -1 0 > -> } { -1 1 > -> } { MIN-INT 0 > -> } { MIN-INT MAX-INT > -> } { 0 MAX-INT > -> } { 0 0 > -> } { 1 1 > -> } { 1 0 > -> } { 2 1 > -> } { 0 -1 > -> } { 1 -1 > -> } { 0 MIN-INT > -> } { MAX-INT MIN-INT > -> } { MAX-INT 0 > -> } { 0 1 U< -> } { 1 2 U< -> } { 0 MID-UINT U< -> } { 0 MAX-UINT U< -> } { MID-UINT MAX-UINT U< -> } { 0 0 U< -> } { 1 1 U< -> } { 1 0 U< -> } { 2 1 U< -> } { MID-UINT 0 U< -> } { MAX-UINT 0 U< -> } { MAX-UINT MID-UINT U< -> } { 0 1 MIN -> 0 } { 1 2 MIN -> 1 } { -1 0 MIN -> -1 } { -1 1 MIN -> -1 } { MIN-INT 0 MIN -> MIN-INT } { MIN-INT MAX-INT MIN -> MIN-INT } { 0 MAX-INT MIN -> 0 } { 0 0 MIN -> 0 } { 1 1 MIN -> 1 } { 1 0 MIN -> 0 } { 2 1 MIN -> 1 } { 0 -1 MIN -> -1 } { 1 -1 MIN -> -1 } { 0 MIN-INT MIN -> MIN-INT } { MAX-INT MIN-INT MIN -> MIN-INT } { MAX-INT 0 MIN -> 0 } { 0 1 MAX -> 1 } { 1 2 MAX -> 2 } { -1 0 MAX -> 0 } { -1 1 MAX -> 1 } { MIN-INT 0 MAX -> 0 } { MIN-INT MAX-INT MAX -> MAX-INT } { 0 MAX-INT MAX -> MAX-INT } { 0 0 MAX -> 0 } { 1 1 MAX -> 1 } { 1 0 MAX -> 1 } { 2 1 MAX -> 2 } { 0 -1 MAX -> 0 } { 1 -1 MAX -> 1 } { 0 MIN-INT MAX -> 0 } { MAX-INT MIN-INT MAX -> MAX-INT } { MAX-INT 0 MAX -> MAX-INT } \ ------------------------------------------------------------------------ TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP { 1 2 2DROP -> } { 1 2 2DUP -> 1 2 1 2 } { 1 2 3 4 2OVER -> 1 2 3 4 1 2 } { 1 2 3 4 2SWAP -> 3 4 1 2 } { 0 ?DUP -> 0 } { 1 ?DUP -> 1 1 } { -1 ?DUP -> -1 -1 } { DEPTH -> 0 } { 0 DEPTH -> 0 1 } { 0 1 DEPTH -> 0 1 2 } { 0 DROP -> } { 1 2 DROP -> 1 } { 1 DUP -> 1 1 } { 1 2 OVER -> 1 2 1 } { 1 2 3 ROT -> 2 3 1 } { 1 2 SWAP -> 2 1 } \ ------------------------------------------------------------------------ TESTING >R R> R@ { : GR1 >R R> ; -> } { : GR2 >R R@ R> DROP ; -> } { 123 GR1 -> 123 } { 123 GR2 -> 123 } { 1S GR1 -> 1S } ( RETURN STACK HOLDS CELLS ) \ ------------------------------------------------------------------------ TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE { 0 5 + -> 5 } { 5 0 + -> 5 } { 0 -5 + -> -5 } { -5 0 + -> -5 } { 1 2 + -> 3 } { 1 -2 + -> -1 } { -1 2 + -> 1 } { -1 -2 + -> -3 } { -1 1 + -> 0 } { MID-UINT 1 + -> MID-UINT+1 } { 0 5 - -> -5 } { 5 0 - -> 5 } { 0 -5 - -> 5 } { -5 0 - -> -5 } { 1 2 - -> -1 } { 1 -2 - -> 3 } { -1 2 - -> -3 } { -1 -2 - -> 1 } { 0 1 - -> -1 } { MID-UINT+1 1 - -> MID-UINT } { 0 1+ -> 1 } { -1 1+ -> 0 } { 1 1+ -> 2 } { MID-UINT 1+ -> MID-UINT+1 } { 2 1- -> 1 } { 1 1- -> 0 } { 0 1- -> -1 } { MID-UINT+1 1- -> MID-UINT } { 0 NEGATE -> 0 } { 1 NEGATE -> -1 } { -1 NEGATE -> 1 } { 2 NEGATE -> -2 } { -2 NEGATE -> 2 } { 0 ABS -> 0 } { 1 ABS -> 1 } { -1 ABS -> 1 } { MIN-INT ABS -> MID-UINT+1 } \ ------------------------------------------------------------------------ TESTING MULTIPLY: S>D * M* UM* { 0 S>D -> 0 0 } { 1 S>D -> 1 0 } { 2 S>D -> 2 0 } { -1 S>D -> -1 -1 } { -2 S>D -> -2 -1 } { MIN-INT S>D -> MIN-INT -1 } { MAX-INT S>D -> MAX-INT 0 } { 0 0 M* -> 0 S>D } { 0 1 M* -> 0 S>D } { 1 0 M* -> 0 S>D } { 1 2 M* -> 2 S>D } { 2 1 M* -> 2 S>D } { 3 3 M* -> 9 S>D } { -3 3 M* -> -9 S>D } { 3 -3 M* -> -9 S>D } { -3 -3 M* -> 9 S>D } { 0 MIN-INT M* -> 0 S>D } { 1 MIN-INT M* -> MIN-INT S>D } { 2 MIN-INT M* -> 0 1S } { 0 MAX-INT M* -> 0 S>D } { 1 MAX-INT M* -> MAX-INT S>D } { 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 } { MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT } { MAX-INT MIN-INT M* -> MSB MSB 2/ } { MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT } { 0 0 * -> 0 } \ TEST IDENTITIES { 0 1 * -> 0 } { 1 0 * -> 0 } { 1 2 * -> 2 } { 2 1 * -> 2 } { 3 3 * -> 9 } { -3 3 * -> -9 } { 3 -3 * -> -9 } { -3 -3 * -> 9 } { MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 } { MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 } { MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 } { 0 0 UM* -> 0 0 } { 0 1 UM* -> 0 0 } { 1 0 UM* -> 0 0 } { 1 2 UM* -> 2 0 } { 2 1 UM* -> 2 0 } { 3 3 UM* -> 9 0 } { MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 } { MID-UINT+1 2 UM* -> 0 1 } { MID-UINT+1 4 UM* -> 0 2 } { 1S 2 UM* -> 1S 1 LSHIFT 1 } { MAX-UINT MAX-UINT UM* -> 1 1 INVERT } \ ------------------------------------------------------------------------ TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD { 0 S>D 1 FM/MOD -> 0 0 } { 1 S>D 1 FM/MOD -> 0 1 } { 2 S>D 1 FM/MOD -> 0 2 } { -1 S>D 1 FM/MOD -> 0 -1 } { -2 S>D 1 FM/MOD -> 0 -2 } { 0 S>D -1 FM/MOD -> 0 0 } { 1 S>D -1 FM/MOD -> 0 -1 } { 2 S>D -1 FM/MOD -> 0 -2 } { -1 S>D -1 FM/MOD -> 0 1 } { -2 S>D -1 FM/MOD -> 0 2 } { 2 S>D 2 FM/MOD -> 0 1 } { -1 S>D -1 FM/MOD -> 0 1 } { -2 S>D -2 FM/MOD -> 0 1 } { 7 S>D 3 FM/MOD -> 1 2 } { 7 S>D -3 FM/MOD -> -2 -3 } { -7 S>D 3 FM/MOD -> 2 -3 } { -7 S>D -3 FM/MOD -> -1 2 } { MAX-INT S>D 1 FM/MOD -> 0 MAX-INT } { MIN-INT S>D 1 FM/MOD -> 0 MIN-INT } { MAX-INT S>D MAX-INT FM/MOD -> 0 1 } { MIN-INT S>D MIN-INT FM/MOD -> 0 1 } { 1S 1 4 FM/MOD -> 3 MAX-INT } { 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT } { 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 } { 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT } { 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 } { 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT } { 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 } { 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT } { 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 } { MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT } { MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT } { MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT } { MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT } { 0 S>D 1 SM/REM -> 0 0 } { 1 S>D 1 SM/REM -> 0 1 } { 2 S>D 1 SM/REM -> 0 2 } { -1 S>D 1 SM/REM -> 0 -1 } { -2 S>D 1 SM/REM -> 0 -2 } { 0 S>D -1 SM/REM -> 0 0 } { 1 S>D -1 SM/REM -> 0 -1 } { 2 S>D -1 SM/REM -> 0 -2 } { -1 S>D -1 SM/REM -> 0 1 } { -2 S>D -1 SM/REM -> 0 2 } { 2 S>D 2 SM/REM -> 0 1 } { -1 S>D -1 SM/REM -> 0 1 } { -2 S>D -2 SM/REM -> 0 1 } { 7 S>D 3 SM/REM -> 1 2 } { 7 S>D -3 SM/REM -> 1 -2 } { -7 S>D 3 SM/REM -> -1 -2 } { -7 S>D -3 SM/REM -> -1 2 } { MAX-INT S>D 1 SM/REM -> 0 MAX-INT } { MIN-INT S>D 1 SM/REM -> 0 MIN-INT } { MAX-INT S>D MAX-INT SM/REM -> 0 1 } { MIN-INT S>D MIN-INT SM/REM -> 0 1 } { 1S 1 4 SM/REM -> 3 MAX-INT } { 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT } { 2 MIN-INT M* MIN-INT SM/REM -> 0 2 } { 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT } { 2 MAX-INT M* MAX-INT SM/REM -> 0 2 } { MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT } { MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT } { MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT } { MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT } { 0 0 1 UM/MOD -> 0 0 } { 1 0 1 UM/MOD -> 0 1 } { 1 0 2 UM/MOD -> 1 0 } { 3 0 2 UM/MOD -> 1 1 } { MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT } { MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 } { MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT } : IFFLOORED [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; : IFSYM [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. IFFLOORED : T/MOD >R S>D R> FM/MOD ; IFFLOORED : T/ T/MOD SWAP DROP ; IFFLOORED : TMOD T/MOD DROP ; IFFLOORED : T*/MOD >R M* R> FM/MOD ; IFFLOORED : T*/ T*/MOD SWAP DROP ; IFSYM : T/MOD >R S>D R> SM/REM ; IFSYM : T/ T/MOD SWAP DROP ; IFSYM : TMOD T/MOD DROP ; IFSYM : T*/MOD >R M* R> SM/REM ; IFSYM : T*/ T*/MOD SWAP DROP ; { 0 1 /MOD -> 0 1 T/MOD } { 1 1 /MOD -> 1 1 T/MOD } { 2 1 /MOD -> 2 1 T/MOD } { -1 1 /MOD -> -1 1 T/MOD } { -2 1 /MOD -> -2 1 T/MOD } { 0 -1 /MOD -> 0 -1 T/MOD } { 1 -1 /MOD -> 1 -1 T/MOD } { 2 -1 /MOD -> 2 -1 T/MOD } { -1 -1 /MOD -> -1 -1 T/MOD } { -2 -1 /MOD -> -2 -1 T/MOD } { 2 2 /MOD -> 2 2 T/MOD } { -1 -1 /MOD -> -1 -1 T/MOD } { -2 -2 /MOD -> -2 -2 T/MOD } { 7 3 /MOD -> 7 3 T/MOD } { 7 -3 /MOD -> 7 -3 T/MOD } { -7 3 /MOD -> -7 3 T/MOD } { -7 -3 /MOD -> -7 -3 T/MOD } { MAX-INT 1 /MOD -> MAX-INT 1 T/MOD } { MIN-INT 1 /MOD -> MIN-INT 1 T/MOD } { MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD } { MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD } { 0 1 / -> 0 1 T/ } { 1 1 / -> 1 1 T/ } { 2 1 / -> 2 1 T/ } { -1 1 / -> -1 1 T/ } { -2 1 / -> -2 1 T/ } { 0 -1 / -> 0 -1 T/ } { 1 -1 / -> 1 -1 T/ } { 2 -1 / -> 2 -1 T/ } { -1 -1 / -> -1 -1 T/ } { -2 -1 / -> -2 -1 T/ } { 2 2 / -> 2 2 T/ } { -1 -1 / -> -1 -1 T/ } { -2 -2 / -> -2 -2 T/ } { 7 3 / -> 7 3 T/ } { 7 -3 / -> 7 -3 T/ } { -7 3 / -> -7 3 T/ } { -7 -3 / -> -7 -3 T/ } { MAX-INT 1 / -> MAX-INT 1 T/ } { MIN-INT 1 / -> MIN-INT 1 T/ } { MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ } { MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ } { 0 1 MOD -> 0 1 TMOD } { 1 1 MOD -> 1 1 TMOD } { 2 1 MOD -> 2 1 TMOD } { -1 1 MOD -> -1 1 TMOD } { -2 1 MOD -> -2 1 TMOD } { 0 -1 MOD -> 0 -1 TMOD } { 1 -1 MOD -> 1 -1 TMOD } { 2 -1 MOD -> 2 -1 TMOD } { -1 -1 MOD -> -1 -1 TMOD } { -2 -1 MOD -> -2 -1 TMOD } { 2 2 MOD -> 2 2 TMOD } { -1 -1 MOD -> -1 -1 TMOD } { -2 -2 MOD -> -2 -2 TMOD } { 7 3 MOD -> 7 3 TMOD } { 7 -3 MOD -> 7 -3 TMOD } { -7 3 MOD -> -7 3 TMOD } { -7 -3 MOD -> -7 -3 TMOD } { MAX-INT 1 MOD -> MAX-INT 1 TMOD } { MIN-INT 1 MOD -> MIN-INT 1 TMOD } { MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD } { MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD } { 0 2 1 */ -> 0 2 1 T*/ } { 1 2 1 */ -> 1 2 1 T*/ } { 2 2 1 */ -> 2 2 1 T*/ } { -1 2 1 */ -> -1 2 1 T*/ } { -2 2 1 */ -> -2 2 1 T*/ } { 0 2 -1 */ -> 0 2 -1 T*/ } { 1 2 -1 */ -> 1 2 -1 T*/ } { 2 2 -1 */ -> 2 2 -1 T*/ } { -1 2 -1 */ -> -1 2 -1 T*/ } { -2 2 -1 */ -> -2 2 -1 T*/ } { 2 2 2 */ -> 2 2 2 T*/ } { -1 2 -1 */ -> -1 2 -1 T*/ } { -2 2 -2 */ -> -2 2 -2 T*/ } { 7 2 3 */ -> 7 2 3 T*/ } { 7 2 -3 */ -> 7 2 -3 T*/ } { -7 2 3 */ -> -7 2 3 T*/ } { -7 2 -3 */ -> -7 2 -3 T*/ } { MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ } { MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ } { 0 2 1 */MOD -> 0 2 1 T*/MOD } { 1 2 1 */MOD -> 1 2 1 T*/MOD } { 2 2 1 */MOD -> 2 2 1 T*/MOD } { -1 2 1 */MOD -> -1 2 1 T*/MOD } { -2 2 1 */MOD -> -2 2 1 T*/MOD } { 0 2 -1 */MOD -> 0 2 -1 T*/MOD } { 1 2 -1 */MOD -> 1 2 -1 T*/MOD } { 2 2 -1 */MOD -> 2 2 -1 T*/MOD } { -1 2 -1 */MOD -> -1 2 -1 T*/MOD } { -2 2 -1 */MOD -> -2 2 -1 T*/MOD } { 2 2 2 */MOD -> 2 2 2 T*/MOD } { -1 2 -1 */MOD -> -1 2 -1 T*/MOD } { -2 2 -2 */MOD -> -2 2 -2 T*/MOD } { 7 2 3 */MOD -> 7 2 3 T*/MOD } { 7 2 -3 */MOD -> 7 2 -3 T*/MOD } { -7 2 3 */MOD -> -7 2 3 T*/MOD } { -7 2 -3 */MOD -> -7 2 -3 T*/MOD } { MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD } { MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD } \ ------------------------------------------------------------------------ TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT HERE 1 ALLOT HERE CONSTANT 2NDA CONSTANT 1STA { 1STA 2NDA U< -> } \ HERE MUST GROW WITH ALLOT { 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT ( MISSING TEST: NEGATIVE ALLOT ) HERE 1 , HERE 2 , CONSTANT 2ND CONSTANT 1ST { 1ST 2ND U< -> } \ HERE MUST GROW WITH ALLOT { 1ST CELL+ -> 2ND } \ ... BY ONE CELL { 1ST 1 CELLS + -> 2ND } { 1ST @ 2ND @ -> 1 2 } { 5 1ST ! -> } { 1ST @ 2ND @ -> 5 2 } { 6 2ND ! -> } { 1ST @ 2ND @ -> 5 6 } { 1ST 2@ -> 6 5 } { 2 1 1ST 2! -> } { 1ST 2@ -> 2 1 } { 1S 1ST ! 1ST @ -> 1S } \ CAN STORE CELL-WIDE VALUE HERE 1 C, HERE 2 C, CONSTANT 2NDC CONSTANT 1STC { 1STC 2NDC U< -> } \ HERE MUST GROW WITH ALLOT { 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR { 1STC 1 CHARS + -> 2NDC } { 1STC C@ 2NDC C@ -> 1 2 } { 3 1STC C! -> } { 1STC C@ 2NDC C@ -> 3 2 } { 4 2NDC C! -> } { 1STC C@ 2NDC C@ -> 3 4 } ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT CONSTANT A-ADDR CONSTANT UA-ADDR { UA-ADDR ALIGNED -> A-ADDR } { 1 A-ADDR C! A-ADDR C@ -> 1 } { 1234 A-ADDR ! A-ADDR @ -> 1234 } { 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 } { 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 } { 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 } { 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 } { 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 } : BITS ( X -- U ) 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) { 1 CHARS 1 < -> } { 1 CHARS 1 CELLS > -> } ( TBD: HOW TO FIND NUMBER OF BITS? ) ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) { 1 CELLS 1 < -> } { 1 CELLS 1 CHARS MOD -> 0 } { 1S BITS 10 < -> } { 0 1ST ! -> } { 1 1ST +! -> } { 1ST @ -> 1 } { -1 1ST +! 1ST @ -> 0 } \ ------------------------------------------------------------------------ TESTING CHAR [CHAR] [ ] BL S" { BL -> 20 } { CHAR X -> 58 } { CHAR HELLO -> 48 } { : GC1 [CHAR] X ; -> } { : GC2 [CHAR] HELLO ; -> } { GC1 -> 58 } { GC2 -> 48 } { : GC3 [ GC1 ] LITERAL ; -> } { GC3 -> 58 } { : GC4 S" XY" ; -> } { GC4 SWAP DROP -> 2 } { GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 } \ ------------------------------------------------------------------------ TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE { : GT1 123 ; -> } { ' GT1 EXECUTE -> 123 } { : GT2 ['] GT1 ; IMMEDIATE -> } { GT2 EXECUTE -> 123 } HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING { GT1STRING FIND -> ' GT1 -1 } { GT2STRING FIND -> ' GT2 1 } ( HOW TO SEARCH FOR NON-EXISTENT WORD? ) { : GT3 GT2 LITERAL ; -> } { GT3 -> ' GT1 } { GT1STRING COUNT -> GT1STRING CHAR+ 3 } { : GT4 POSTPONE GT1 ; IMMEDIATE -> } { : GT5 GT4 ; -> } { GT5 -> 123 } { : GT6 345 ; IMMEDIATE -> } { : GT7 POSTPONE GT6 ; -> } { GT7 -> 345 } { : GT8 STATE @ ; IMMEDIATE -> } { GT8 -> 0 } { : GT9 GT8 LITERAL ; -> } { GT9 0= -> } \ ------------------------------------------------------------------------ TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE { : GI1 IF 123 THEN ; -> } { : GI2 IF 123 ELSE 234 THEN ; -> } { 0 GI1 -> } { 1 GI1 -> 123 } { -1 GI1 -> 123 } { 0 GI2 -> 234 } { 1 GI2 -> 123 } { -1 GI1 -> 123 } { : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> } { 0 GI3 -> 0 1 2 3 4 5 } { 4 GI3 -> 4 5 } { 5 GI3 -> 5 } { 6 GI3 -> 6 } { : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> } { 3 GI4 -> 3 4 5 6 } { 5 GI4 -> 5 6 } { 6 GI4 -> 6 7 } { : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> } { 1 GI5 -> 1 345 } { 2 GI5 -> 2 345 } { 3 GI5 -> 3 4 5 123 } { 4 GI5 -> 4 5 123 } { 5 GI5 -> 5 123 } { : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> } { 0 GI6 -> 0 } { 1 GI6 -> 0 1 } { 2 GI6 -> 0 1 2 } { 3 GI6 -> 0 1 2 3 } { 4 GI6 -> 0 1 2 3 4 } \ ------------------------------------------------------------------------ TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT { : GD1 DO I LOOP ; -> } { 4 1 GD1 -> 1 2 3 } { 2 -1 GD1 -> -1 0 1 } { MID-UINT+1 MID-UINT GD1 -> MID-UINT } { : GD2 DO I -1 +LOOP ; -> } { 1 4 GD2 -> 4 3 2 1 } { -1 2 GD2 -> 2 1 0 -1 } { MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT } { : GD3 DO 1 0 DO J LOOP LOOP ; -> } { 4 1 GD3 -> 1 2 3 } { 2 -1 GD3 -> -1 0 1 } { MID-UINT+1 MID-UINT GD3 -> MID-UINT } { : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> } { 1 4 GD4 -> 4 3 2 1 } { -1 2 GD4 -> 2 1 0 -1 } { MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT } { : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> } { 1 GD5 -> 123 } { 5 GD5 -> 123 } { 6 GD5 -> 234 } { : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) 0 SWAP 0 DO I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP LOOP ; -> } { 1 GD6 -> 1 } { 2 GD6 -> 3 } { 3 GD6 -> 4 1 2 } \ ------------------------------------------------------------------------ TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY { 123 CONSTANT X123 -> } { X123 -> 123 } { : EQU CONSTANT ; -> } { X123 EQU Y123 -> } { Y123 -> 123 } { VARIABLE V1 -> } { 123 V1 ! -> } { V1 @ -> 123 } { : NOP : POSTPONE ; ; -> } { NOP NOP1 NOP NOP2 -> } { NOP1 -> } { NOP2 -> } { : DOES1 DOES> @ 1 + ; -> } { : DOES2 DOES> @ 2 + ; -> } { CREATE CR1 -> } { CR1 -> HERE } { ' CR1 >BODY -> HERE } { 1 , -> } { CR1 @ -> 1 } { DOES1 -> } { CR1 -> 2 } { DOES2 -> } { CR1 -> 3 } { : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> } { WEIRD: W1 -> } { ' W1 >BODY -> HERE } { W1 -> HERE 1 + } { W1 -> HERE 2 + } \ ------------------------------------------------------------------------ TESTING EVALUATE : GE1 S" 123" ; IMMEDIATE : GE2 S" 123 1+" ; IMMEDIATE : GE3 S" : GE4 345 ;" ; : GE5 EVALUATE ; IMMEDIATE { GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE ) { GE2 EVALUATE -> 124 } { GE3 EVALUATE -> } { GE4 -> 345 } { : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE ) { GE6 -> 123 } { : GE7 GE2 GE5 ; -> } { GE7 -> 124 } \ ------------------------------------------------------------------------ TESTING SOURCE >IN WORD : GS1 S" SOURCE" 2DUP EVALUATE >R SWAP >R = R> R> = ; { GS1 -> } VARIABLE SCANS : RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; { 2 SCANS ! 345 RESCAN? -> 345 345 } : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; { GS2 -> 123 123 123 123 123 } : GS3 WORD COUNT SWAP C@ ; { BL GS3 HELLO -> 5 CHAR H } { CHAR " GS3 GOODBYE" -> 7 CHAR G } { BL GS3 DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING : GS4 SOURCE >IN ! DROP ; { GS4 123 456 -> } \ ------------------------------------------------------------------------ TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH R> ?DUP IF \ IF NON-EMPTY STRINGS 0 DO OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN SWAP CHAR+ SWAP CHAR+ LOOP THEN 2DROP \ IF WE GET HERE, STRINGS MATCH ELSE R> DROP 2DROP \ LENGTHS MISMATCH THEN ; : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; { GP1 -> } : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; { GP2 -> } : GP3 <# 1 0 # # #> S" 01" S= ; { GP3 -> } : GP4 <# 1 0 #S #> S" 1" S= ; { GP4 -> } 24 CONSTANT MAX-BASE \ BASE 2 .. 36 : COUNT-BITS 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD : GP5 BASE @ MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE I BASE ! \ TBD: ASSUMES BASE WORKS I 0 <# #S #> S" 10" S= AND LOOP SWAP BASE ! ; { GP5 -> } : GP6 BASE @ >R 2 BASE ! MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY R> BASE ! \ S: C-ADDR U DUP #BITS-UD = SWAP 0 DO \ S: C-ADDR FLAG OVER C@ [CHAR] 1 = AND \ ALL ONES >R CHAR+ R> LOOP SWAP DROP ; { GP6 -> } : GP7 BASE @ >R MAX-BASE BASE ! A 0 DO I 0 <# #S #> 1 = SWAP C@ I 30 + = AND AND LOOP MAX-BASE A DO I 0 <# #S #> 1 = SWAP C@ 41 I A - + = AND AND LOOP R> BASE ! ; { GP7 -> } \ >NUMBER TESTS CREATE GN-BUF 0 C, : GN-STRING GN-BUF 1 ; : GN-CONSUMED GN-BUF CHAR+ 0 ; : GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; { 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED } { 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED } { 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED } { 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE { 0 0 GN' +' >NUMBER -> 0 0 GN-STRING } { 0 0 GN' .' >NUMBER -> 0 0 GN-STRING } : >NUMBER-BASED BASE @ >R BASE ! >NUMBER R> BASE ! ; { 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED } { 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING } { 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED } { 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING } { 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED } { 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED } : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. BASE @ >R BASE ! <# #S #> 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY R> BASE ! ; { 0 0 2 GN1 -> 0 0 0 } { MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 } { MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 } { 0 0 MAX-BASE GN1 -> 0 0 0 } { MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 } { MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 } : GN2 \ ( -- 16 10 ) BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; { GN2 -> 10 A } \ ------------------------------------------------------------------------ TESTING FILL MOVE CREATE FBUF 00 C, 00 C, 00 C, CREATE SBUF 12 C, 34 C, 56 C, : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; { FBUF 0 20 FILL -> } { SEEBUF -> 00 00 00 } { FBUF 1 20 FILL -> } { SEEBUF -> 20 00 00 } { FBUF 3 20 FILL -> } { SEEBUF -> 20 20 20 } { FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE { SEEBUF -> 20 20 20 } { SBUF FBUF 0 CHARS MOVE -> } { SEEBUF -> 20 20 20 } { SBUF FBUF 1 CHARS MOVE -> } { SEEBUF -> 12 20 20 } { SBUF FBUF 3 CHARS MOVE -> } { SEEBUF -> 12 34 56 } { FBUF FBUF CHAR+ 2 CHARS MOVE -> } { SEEBUF -> 12 12 34 } { FBUF CHAR+ FBUF 2 CHARS MOVE -> } { SEEBUF -> 12 34 34 } \ ------------------------------------------------------------------------ TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. : OUTPUT-TEST ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 41 BL DO I EMIT LOOP CR 61 41 DO I EMIT LOOP CR 7F 61 DO I EMIT LOOP CR ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 9 1+ 0 DO I . LOOP CR ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR ." YOU SHOULD SEE TWO SEPARATE LINES:" CR S" LINE 1" TYPE CR S" LINE 2" TYPE CR ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR ." SIGNED: " MIN-INT . MAX-INT . CR ." UNSIGNED: " 0 U. MAX-UINT U. CR ; { OUTPUT-TEST -> } \ ------------------------------------------------------------------------ \ commented out to allow batch testing -anton \ TESTING INPUT: ACCEPT \ \ CREATE ABUF 80 CHARS ALLOT \ \ : ACCEPT-TEST \ CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR \ ABUF 80 ACCEPT \ CR ." RECEIVED: " [CHAR] " EMIT \ ABUF SWAP TYPE [CHAR] " EMIT CR \ ; \ \ { ACCEPT-TEST -> } \ \ ------------------------------------------------------------------------ TESTING DICTIONARY SEARCH RULES { : GDX 123 ; : GDX GDX 234 ; -> } { GDX -> 123 234 } ./version081/test_code/fragment_test.html0100777000000000000000000001530707300314371017344 0ustar rootroot COLDFORTH KERNEL

testing fragmination of datagrams

license RFC791 IP specification

This is development test code, you have to recompile the kernal with verious constant set to particular values for the test to give the desired stress 

 
: ??= = not ABORT" Should be equal" ;
: ??> > not ABORT" Should be greater" ;
\ override with code as required
interface_common class

	m: ( parent_instance --)
		this [parent] :construct
		\ fragments should be 16 bytes long 
		\ most tests require this set to $14
		$14 ip_data + %%ni_mtu !
		NIS_UP %%ni_state !
	; overrides :construct

	\ queue the packets for our viewing pleasure.
	\ Remember the rules, if you can get rid of it drop it. 
	\ Whatever happens the packet must be consumed.
	#20 8 net_queue test_queue
	m: { variable  %pep -- }
		%pep @ test_queue 0 enqueue_try IF
			NIP
			%pep @ kill_free_buffer
		THEN
	; overrides :write_ip

	\ consume_interface
	m: { variable %pep  -- ( $ ) }
		\ just to remind people this is were this test is done	
		%%ni_state @ NIS_UP <> IF
			%pep @ kill_free_buffer
			$ni_not_up
			EXIT
		THEN
		%pep @ ip>wire
	; overrides :consume_interface  ( pep -- $)


end_class test_fragment

\ the proto task has to be disable
\ the fragment_timeout task has to be disabled

test_fragment heap_object CONSTANT test_object
interface_local heap_object CONSTANT local_test

\ pep for test
: simple_pep { variable %fragment_offset variable %id variable %data_length -- variable %pep }
	\ get a long enough buffer
	ep_data ip_data + %data_length @ + get_free_buffer %pep !
	\ file the data portion with a long word offset
	\ even if a byte length was request the buffer will
	\ be long enough to take a word store at end
	zero \ value<--
	%pep @ ep_data + ip_data + \ value base<--
	DUP %data_length @ + SWAP DO
		DUP I !
		4+
	4 +LOOP
	DROP
	\ set up ep header
	%pep @ ep_data ERASE
	%data_length @ ep_data + ip_data + %pep @ ep_len + !
	
	\ set up ip header
	%pep @ ep_data + ip_data ERASE
	IP_VERSION 4 LSHIFT ip_data 2 RSHIFT OR 
	%pep @ [ ep_data ip_verlen + ] LITERAL + B!  
	%data_length @ ip_data + %pep @ [ ep_data ip_len + ] LITERAL + W!
	%id @ %pep @ [ ep_data ip_id + ] LITERAL + W!
	%fragment_offset @ %pep @ [ ep_data ip_fragoff + ] LITERAL + W!
	IP_TTL  %pep @ [ ep_data ip_ttl + ] LITERAL + B!
	IPT_UDP %pep @ [ ep_data ip_proto + ] LITERAL + W!
	$12345678 %pep @ [ ep_data ip_src + ] LITERAL + ! 
	$44448888 %pep @ [ ep_data ip_dst + ] LITERAL + !
;	


: display_ip { variable %pep ( --) }
	CR
	%pep @ .h
	%pep @ [ ep_data ip_verlen + ] LITERAL + B@ 
	DUP $F0 AND 4 RSHIFT .h 
	$0F AND 2 LSHIFT .h 
	%pep @ [ ep_data ip_tos + ] LITERAL + B@ .h 
	%pep @ [ ep_data ip_len + ] LITERAL + W@ .h
	%pep @ [ ep_data ip_id + ] LITERAL + W@ .h
	%pep @ [ ep_data ip_fragoff + ] LITERAL + W@ .h 
\	%pep @ [ ep_data ip_ttl + ] LITERAL + B@ .h 
	%pep @ [ ep_data ip_proto + ] LITERAL + W@ .h 
;

: ip_header
	CR
	." address  "
	."  version "
	." head_len "
	."      tos "
	."   length "
	."       id "
	." fragment "
\	."      ttl "
	." protocol "
;
: display_queue ( --)
	ip_header
	test_queue  #queue_data_length + #queue_list_head + BEGIN
		@ ?DUP 
	WHILE
		DUP display_ip
	REPEAT
;

: display_proto ( --)
	ip_header
	_proto_queue  #queue_data_length + #queue_list_head + BEGIN
		@ ?DUP 
	WHILE
		DUP display_ip
	REPEAT
;

: tf  ( -- 0|pep)
	BEGIN
		test_queue dequeue
		?DUP
	WHILE
		local_test :consume_interface
	REPEAT
;

\ requires
\		$14 ip_data + %%ni_mtu !
\ this is the first fragment belonging to %pep2
zero 01 $80 simple_pep CONSTANT %pep1 .S
%pep1 display_ip .S
%pep1 test_object :consume_interface 0 ??=
02  02 $83 simple_pep  test_object :consume_interface 0 ??=
\ first fragment arrived second
IP_MF 02 $10 simple_pep test_object :consume_interface 0 ??=
display_queue



tf
CR .( should be empty)
display_queue
CR .( two peps )
display_proto


IP_MF $0C + 03 $80   simple_pep test_object :consume_interface 0 ??=
tf

$0E 03 $80  simple_pep test_object :consume_interface 0 ??=
IP_MF 03 $20 simple_pep test_object :consume_interface 0 ??=
IP_MF 04 + 03 $40 simple_pep test_object :consume_interface 0 ??=
display_queue
tf
.( should now have three ip's on proto queue)
display_proto

_proto_queue dequeue not 0 ??=
_proto_queue dequeue not 0 ??=
_proto_queue dequeue not 0 ??=
_proto_queue dequeue 0 ??=
\ clean out table
_fragment_table_timeout
%fragment_memory_use @  .S 
0 ??=


\ stress test
\ -------------------------------
\ maximum number of peps
\ -------------------------------
\ _#fpt_max_fp has to be set at $40
\ 	_#frag_max_data_length set to value greater than $400
\ IP_FTTL set to 1sec
\ in :construct need the code




\ 16
IP_MF 04 $100 simple_pep test_object :consume_interface 0 ??=
tf
\ 32
IP_MF 20 + 04 $100 simple_pep test_object :consume_interface 0 ??=
tf
\ 48
IP_MF 40 + 04 $100 simple_pep test_object :consume_interface 0 ??=
tf
\ 64
IP_MF 60 + 04 $100 simple_pep test_object :consume_interface 0 ??=
tf
\ table entry should still be there in full glory
%fragment_memory_use @
\ this should see the peps resturned
IP_MF 60 + 04 $100 simple_pep test_object :consume_interface 0 ??=
tf
%fragment_memory_use @ ??> 

: wait 
." about to wait a 2 seconds" send
xtest #1sec 2*  xwait ;
wait

_fragment_table_timeout

%fragment_memory_use @ 0 ??=

\ stress test
\ -------------------------------
\ maximum data in one ip packet
\ -------------------------------
\ 	_#frag_max_data_length set to $400
\ _#fpt_max_fp has to be set at value greater than $40
\ $100
IP_MF 04 $100 simple_pep test_object :concume_interface 0 ??=
tf
\ $200
IP_MF 20 + 04 $100 simple_pep test_object :concume_interface 0 ??=
tf
\ $300
IP_MF 40 + 04 $100 simple_pep test_object :concume_interface 0 ??=
tf
\ $400
IP_MF 60 + 04 $100 simple_pep test_object :concume_interface 0 ??=
tf
\ table entry should still be there in full glory
%fragment_memory_use @
\ this should see the peps resturned
IP_MF 60 + 04 $100 simple_pep test_object :concume_interface 0 ??=
tf
%fragment_memory_use @ ??> 

: wait 
." about to wait a 2 seconds" send
xtest #1sec 2*  xwait ;
wait

_fragment_table_timeout

%fragment_memory_use @ 0 ??=

\ ok I think that is enough.
./version081/test_code/queue_test.html0100777000000000000000000000676307300314371016673 0ustar rootroot COLDFORTH KERNEL license 
 
: ??= <> ABORT" Something wrong" ;
$10 8 net_queue fred
ram_create a0 10 ram_allot
ram_create a1  10 ram_allot
ram_create a2  10 ram_allot
ram_create a3  10 ram_allot
ram_create a4  10 ram_allot
ram_create a5  10 ram_allot
ram_create a6  10 ram_allot
ram_create a7  10 ram_allot
ram_create a8  10 ram_allot
ram_create a9  10 ram_allot
ram_create aA  10 ram_allot
ram_create aB  10 ram_allot
ram_create aC  10 ram_allot
ram_create aD  10 ram_allot
ram_create aE  10 ram_allot
ram_create aF  10 ram_allot
ram_create a10 10 ram_allot
ram_create a11 10 ram_allot
ram_create a12 10 ram_allot
ram_create a13 10 ram_allot
ram_create a14 10 ram_allot
ram_create a15 10 ram_allot
ram_create a16 10 ram_allot
ram_create a17 10 ram_allot
ram_create a18 10 ram_allot
ram_create a19 10 ram_allot
ram_create a1A 10 ram_allot
ram_create a1B 10 ram_allot
ram_create a1C 10 ram_allot
ram_create a1D 10 ram_allot
ram_create a1E 10 ram_allot
ram_create a1F 10 ram_allot

a0 fred 7 enqueue_try 0 ??=
a1 fred 6 enqueue_try 0 ??=
a2 fred 5 enqueue_try 0 ??=
a3 fred 4 enqueue_try 0 ??=
a4 fred 3 enqueue_try 0 ??=
a5 fred 2 enqueue_try 0 ??=
a6 fred 1 enqueue_try 0 ??=
a7 fred 0 enqueue_try 0 ??=
a8 fred 7 enqueue_try 0 ??=
a9 fred 6 enqueue_try 0 ??=
aA fred 5 enqueue_try 0 ??=
aB fred 4 enqueue_try 0 ??=
aC fred 3 enqueue_try 0 ??=
aD fred 2 enqueue_try 0 ??=
aE fred 1 enqueue_try 0 ??=
aF fred 0 enqueue_try 0 ??=
\ limit exceeded should fail
a10 fred 0 enqueue_try 0= FALSE ??=

\ should come off in priority order
fred dequeue a0 ??=
fred dequeue a8 ??=
fred dequeue a1 ??=
fred dequeue a9 ??= 
fred dequeue a2 ??=
fred dequeue aA ??=
fred dequeue a3 ??=
fred dequeue aB ??=
fred dequeue a4 ??=
fred dequeue aC ??=
fred dequeue a5 ??=
fred dequeue aD ??=
fred dequeue a6 ??=
fred dequeue aE ??=
fred dequeue a7 ??=
fred dequeue aF ??=
fred dequeue 0  ??=


\ start a task that consumes packets real slow

	: task_action
		BEGIN
			fred xawait
			fred dequeue
			DROP
			xtest #100 xwait
		AGAIN
	;

	#clock_low task: fred_task 
		task_action
	;task

	ALSO &tasks
	fred_task taskin
	PREVIOUS

	: xx ." ." send ;

\ should see 16 dots, and then one every sec
xx a0 fred 7 enqueue_wait 
xx a1 fred 6 enqueue_wait 
xx a2 fred 5 enqueue_wait 
xx a3 fred 4 enqueue_wait 
xx a4 fred 3 enqueue_wait 
xx a5 fred 2 enqueue_wait 
xx a6 fred 1 enqueue_wait 
xx a7 fred 0 enqueue_wait 
xx a8 fred 7 enqueue_wait 
xx a9 fred 6 enqueue_wait 
xx aA fred 5 enqueue_wait 
xx aB fred 4 enqueue_wait 
xx aC fred 3 enqueue_wait 
xx aD fred 2 enqueue_wait 
xx aE fred 1 enqueue_wait 
xx aF fred 0 enqueue_wait 

xx a10 fred 0 enqueue_wait 
xx a11 fred 6 enqueue_wait 
xx a12 fred 5 enqueue_wait 
xx a13 fred 4 enqueue_wait 
xx a14 fred 3 enqueue_wait 
xx a15 fred 2 enqueue_wait 
xx a16 fred 1 enqueue_wait 
xx a17 fred 0 enqueue_wait 
xx a18 fred 7 enqueue_wait 
xx a19 fred 6 enqueue_wait 
xx a1A fred 5 enqueue_wait 
xx a1B fred 4 enqueue_wait 
xx a1C fred 3 enqueue_wait 
xx a1D fred 2 enqueue_wait 
xx a1E fred 1 enqueue_wait 
xx a1F fred 0 enqueue_wait 
.( should be nothing on stack)
.S
./version081/test_code/route2_test.html0100777000000000000000000000301607300314371016753 0ustar rootroot COLDFORTH KERNEL 
 

\ pep for test
: simple_pep { variable %fragment_offset variable %id variable %data_length -- variable %pep }
	\ get a long enough buffer
	ep_data ip_data + %data_length @ + get_free_buffer %pep !
	\ file the data portion with a long word offset
	\ even if a byte length was request the buffer will
	\ be long enough to take a word store at end
	zero \ value<--
	%pep @ ep_data + ip_data + \ value base<--
	DUP %data_length @ + SWAP DO
		DUP I !
		4+
	4 +LOOP
	DROP
	\ set up ep header
	%pep @ ep_data ERASE
	%data_length @ ep_data + ip_data + %pep @ ep_len + !
	
	\ set up ip header
	%pep @ ep_data + ip_data ERASE
	IP_VERSION 4 LSHIFT ip_data 2 RSHIFT OR 
	%pep @ [ ep_data ip_verlen + ] LITERAL + B!  
	%data_length @ ip_data + %pep @ [ ep_data ip_len + ] LITERAL + W!
	%id @ %pep @ [ ep_data ip_id + ] LITERAL + W!
	%fragment_offset @ %pep @ [ ep_data ip_fragoff + ] LITERAL + W!
	IP_TTL  %pep @ [ ep_data ip_ttl + ] LITERAL + B!
	IPT_UDP %pep @ [ ep_data ip_proto + ] LITERAL + W!
	$12345678 %pep @ [ ep_data ip_src + ] LITERAL + !
	\ loop back 
	$7F000001 %pep @ [ ep_data ip_dst + ] LITERAL + !
;	


0 03 $80   simple_pep CONSTANT  %pep1


%pep1 queue_ip
./version081/test_code/route_test.html0100777000000000000000000000723507300314371016700 0ustar rootroot COLDFORTH KERNEL license 
 
: ??= = not ABORT" Should be equal" ;
: ??> > not ABORT" Should be greater" ;

\ pep for test
: simple_pep { variable %destination variable %fragment_offset variable %id variable %data_length -- variable %pep }
	\ get a long enough buffer
	ep_data ip_data + %data_length @ + get_free_buffer %pep !
	\ file the data portion with a long word offset
	\ even if a byte length was request the buffer will
	\ be long enough to take a word store at end
	zero \ value<--
	%pep @ ep_data + ip_data + \ value base<--
	DUP %data_length @ + SWAP DO
		DUP I !
		4+
	4 +LOOP
	DROP
	\ set up ep header
	%pep @ ep_data ERASE
	%data_length @ ep_data + ip_data + %pep @ ep_len + !
	
	\ set up ip header
	%pep @ ep_data + ip_data ERASE
	IP_VERSION 4 LSHIFT ip_data 2 RSHIFT OR 
	%pep @ [ ep_data ip_verlen + ] LITERAL + B!  
	%data_length @ ip_data + %pep @ [ ep_data ip_len + ] LITERAL + W!
	%id @ %pep @ [ ep_data ip_id + ] LITERAL + W!
	%fragment_offset @ %pep @ [ ep_data ip_fragoff + ] LITERAL + W!
	IP_TTL  %pep @ [ ep_data ip_ttl + ] LITERAL + B!
	IPT_UDP %pep @ [ ep_data ip_proto + ] LITERAL + W!
	$12345678 %pep @ [ ep_data ip_src + ] LITERAL + ! 
	%destination @ %pep @ [ ep_data ip_dst + ] LITERAL + !
;	


: display_ip { variable %pep ( --) }
	CR
	%pep @ .h
	%pep @ [ ep_data ip_verlen + ] LITERAL + B@ 
	DUP $F0 AND 4 RSHIFT .h 
	$0F AND 2 LSHIFT .h 
	%pep @ [ ep_data ip_tos + ] LITERAL + B@ .h 
	%pep @ [ ep_data ip_len + ] LITERAL + W@ .h
	%pep @ [ ep_data ip_id + ] LITERAL + W@ .h
	%pep @ [ ep_data ip_fragoff + ] LITERAL + W@ .h 
\	%pep @ [ ep_data ip_ttl + ] LITERAL + B@ .h 
	%pep @ [ ep_data ip_proto + ] LITERAL + W@ .h 
;

: ip_header
	CR
	." address  "
	."  version "
	." head_len "
	."      tos "
	."   length "
	."       id "
	." fragment "
\	."      ttl "
	." protocol "
;

\ setup loopback
\ net           mask       gw        metric   tos
\ default
000:000:000:000 $00000000 $01000000 RTM_INF 1- $00000000 01 static_route
\ local
127:000:000:001 $FFFFFFFF $00000000 $00000000 $00000000 02 static_route
127:000:000:000 $FF000000 $00000000 $00000000 $00000000 03 static_route
\ local machine
200:000:000:001 $FFFFFFFF $00000000 $00000000 $00000000 04 static_route
\ machine on local net
200:000:000:000 $FFFFFF00 $00000000 $00000001 $00000000 05 static_route



127:000:000:000 00 01 80 simple_pep CONSTANT %pep1 

%pep1 _route_get DUP .S  rt_interface + @ .S 03 ??= _route_free

201:000:000:000 00 01 80 simple_pep CONSTANT %pep2

%pep2 _route_get DUP rt_interface + @ 01 ??= _route_free

\ install a better default route
000:000:000:000 $00000000 $03000000 $0000001E $00000000 06 static_route
%pep2 _route_get DUP rt_interface + @ 06 ??= _route_free

\ change the distance of first so it is better
000:000:000:000 $00000000 $01000000 $0000001C $00000000 01 static_route
%pep2 _route_get DUP rt_interface + @ 01 ??= _route_free

\ add a super hot route for default that has a timeout
000:000:000:000 $00000000 $01000000 $0000001F $00000000 07 #1sec RT_ICC_REDIRECT route_add 0 ??=
%pep2 _route_get DUP rt_interface + @ 07 ??= _route_free
0 0 ip>hash %rttable + @ $40 DUMP
\ wait 2 sec
: wait 
." about to wait a 2 seconds" send
xtest #1sec 2*  xwait ;
wait
\ time out route
rttimer
%pep2 _route_get DUP rt_interface + @ 01 ??= _route_free
./version081/test_code/tester.4th0100777000000000000000000000327407300314371015543 0ustar rootroot\ From: John Hayes S1I \ Subject: tester.fr \ Date: Mon, 27 Nov 95 13:10:09 PST \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. \ VERSION 1.1 MARKER empty HEX \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. VARIABLE VERBOSE TRUE VERBOSE ! : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY \ THE LINE THAT HAD THE ERROR. TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR EMPTY-STACK \ THROW AWAY EVERY THING ELSE ; VARIABLE ACTUAL-DEPTH \ STACK RECORD CREATE ACTUAL-RESULTS 20 CELLS ALLOT : { \ ( -- ) SYNTACTIC SUGAR. ; : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH ?DUP IF \ IF THERE IS SOMETHING ON STACK 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM THEN ; : } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED \ (ACTUAL) CONTENTS. DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 0 DO \ FOR EACH STACK ITEM ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN LOOP THEN ELSE \ DEPTH MISMATCH S" WRONG NUMBER OF RESULTS: " ERROR THEN ; : TESTING \ ( -- ) TALKING COMMENT. SOURCE VERBOSE @ IF DUP >R TYPE CR R> >IN ! ELSE >IN ! DROP THEN ; ./version081/test_code/udp_test.html0100777000000000000000000000066407300314371016331 0ustar rootroot COLDFORTH KERNEL

udp_test

license 
 
udp_demux heap_object CONSTANT dp
./version081/test_code/test.4th0100755000000000000000000000335507300314371015210 0ustar rootroot \ float test : ??= = not ABORT" Problems" ; HEX \ difficult adds 7FFFFFFF+0 1+0 F+ F>D 80000000L D= TRUE ??= -7FFFFFFF+0 -1+0 F+ F>D -80000000L D= TRUE ??= \ division sign -80000000+0 2+0 F/ F>D -40000000L D= TRUE ??= -80000000+0 -2+0 F/ F>D 40000000L D= TRUE ??= 80000000+0 2+0 F/ F>D 40000000L D= TRUE ??= 80000000+0 -2+0 F/ F>D -40000000L D= TRUE ??= \ rounding; you may not like the result but this is what I expect. \ 7FFFFFFF 2 / = 3FFFFFFF.8 ( half a hex) \ CONVERT to Integer 40000000 \ This is what happens if rounding up. 7FFFFFFF+ 2+0 F/ F>D 40000000L D= TRUE ??= 7FFFFFFE+ 2+0 F/ F>D 3FFFFFFFL D= TRUE ??= ram_variable %a $80 ram_allot ram_variable %b $80 ram_allot ram_variable %c $80 ram_allot DECIMAL 101E2 %a F! 102E2 %a 1 FLOATS + F! 103E2 %a 2 FLOATS + F! 104E2 %a 3 FLOATS + F! 105E2 %a 4 FLOATS + F! 106E2 %a 5 FLOATS + F! 107E2 %a 6 FLOATS + F! 108E2 %a 7 FLOATS + F! 109E2 %a 8 FLOATS + F! 1E2 %b F! 2E2 %b 1 FLOATS + F! 3E2 %b 2 FLOATS + F! 4E2 %b 3 FLOATS + F! 5E2 %b 4 FLOATS + F! 6E2 %b 5 FLOATS + F! 7E2 %b 6 FLOATS + F! 8E2 %b 7 FLOATS + F! 9E2 %b 8 FLOATS + F! : tv*v ." va * vb = vc " CR send %a %b %c 8 fv*fv CR %a 8 fv. send CR %b 8 fv. send CR %c 8 fv. send ; : tv+v ." va + vb = vc " CR send %a %b %c 8 fv+fv CR %a 8 fv. send CR %b 8 fv. send CR %c 8 fv. send ; : tv-v ." va - vb = vc " CR send %a %b %c 8 fv-fv CR %a 8 fv. send CR %b 8 fv. send CR %c 8 fv. send ; : tv*c ." va * b = vc " CR send %a %b FLOAT+ F@ %c 8 fv*f CR %a 8 fv. send CR %b FLOAT+ F@ FS. CR CR %c 8 fv. send ; : tv+f ." fa + b = vc" CR send %a %b FLOAT+ F@ %c 8 fv+f CR %a 8 fv. send CR %b FLOAT+ F@ FS. CR CR %c 8 fv. send ; ./version081/test_code/float_test.4th0100644000000000000000000000335507300314371016372 0ustar rootroot \ float test : ??= = not ABORT" Problems" ; HEX \ difficult adds 7FFFFFFF+0 1+0 F+ F>D 80000000L D= TRUE ??= -7FFFFFFF+0 -1+0 F+ F>D -80000000L D= TRUE ??= \ division sign -80000000+0 2+0 F/ F>D -40000000L D= TRUE ??= -80000000+0 -2+0 F/ F>D 40000000L D= TRUE ??= 80000000+0 2+0 F/ F>D 40000000L D= TRUE ??= 80000000+0 -2+0 F/ F>D -40000000L D= TRUE ??= \ rounding; you may not like the result but this is what I expect. \ 7FFFFFFF 2 / = 3FFFFFFF.8 ( half a hex) \ CONVERT to Integer 40000000 \ This is what happens if rounding up. 7FFFFFFF+ 2+0 F/ F>D 40000000L D= TRUE ??= 7FFFFFFE+ 2+0 F/ F>D 3FFFFFFFL D= TRUE ??= ram_variable %a $80 ram_allot ram_variable %b $80 ram_allot ram_variable %c $80 ram_allot DECIMAL 101E2 %a F! 102E2 %a 1 FLOATS + F! 103E2 %a 2 FLOATS + F! 104E2 %a 3 FLOATS + F! 105E2 %a 4 FLOATS + F! 106E2 %a 5 FLOATS + F! 107E2 %a 6 FLOATS + F! 108E2 %a 7 FLOATS + F! 109E2 %a 8 FLOATS + F! 1E2 %b F! 2E2 %b 1 FLOATS + F! 3E2 %b 2 FLOATS + F! 4E2 %b 3 FLOATS + F! 5E2 %b 4 FLOATS + F! 6E2 %b 5 FLOATS + F! 7E2 %b 6 FLOATS + F! 8E2 %b 7 FLOATS + F! 9E2 %b 8 FLOATS + F! : tv*v ." va * vb = vc " CR send %a %b %c 8 fv*fv CR %a 8 fv. send CR %b 8 fv. send CR %c 8 fv. send ; : tv+v ." va + vb = vc " CR send %a %b %c 8 fv+fv CR %a 8 fv. send CR %b 8 fv. send CR %c 8 fv. send ; : tv-v ." va - vb = vc " CR send %a %b %c 8 fv-fv CR %a 8 fv. send CR %b 8 fv. send CR %c 8 fv. send ; : tv*c ." va * b = vc " CR send %a %b FLOAT+ F@ %c 8 fv*f CR %a 8 fv. send CR %b FLOAT+ F@ FS. CR CR %c 8 fv. send ; : tv+f ." fa + b = vc" CR send %a %b FLOAT+ F@ %c 8 fv+f CR %a 8 fv. send CR %b FLOAT+ F@ FS. CR CR %c 8 fv. send ; ./version081/history.html0100777000000000000000000000315307300314345014227 0ustar rootroot COLDFORTH KERNEL

history

license

Version 0.5

1) The file objects reworked, stucture is now a lot neater.
2) NFS added
3) telnet client improved ( unix client only, NT sucks)
4) Some bug fixes.

Version 0.7

1)More work on file objects.
2)More work on telnet; moved to charater mode so it works better with NT.
4)More work with telnet, function keys working.
5)TCP data stream now sorted out in proto task so ^C can be made to work.
6)TCP now times out properly; was no activity for a long time; now can't find other end for a short time. Needed for HTML server.
7)Assembler now supports 5407.
8)Watchdog task now works.
9).objects added.
10)Additional test in ?buffer.
11)Ansi terminal driver.
12):termination>code consistant across telnet and ttx so common drivers can be used, was a mistake.
13)string_class added; needed for HTML server.
14)lower case characters in hex numbers, needed for HTML server. Still not finished.

Version 0.8

1)Bug in telnet_client :read.
2)Floating point basic word set added.
3)Q number words start with Q for example q. q.l and q.r. The Q base is now called %q_base
4)pure_code changed to inline

It is getting to a stage where it is a pleasure to use.

./version081/_cvs_decode.html0100777000000000000000000002536607300314345014775 0ustar rootroot COLDFORTH KERNEL

CVS packed terminal control decode

license 
 
	HEX
	: portC@ ( addr --)
		DUP 01 AND IF
			$FFFFFFFE AND
			\ low byte
			W@ 
		ELSE
			\ high byte
			W@ 8 RSHIFT 
		THEN
		$FF AND
	;

	??HEX
	$80 CONSTANT _#first_code_character
	0  CONSTANT _#exit_code

	: _=command { variable _%point variable _%count -- ( addr count data)  }{
	
		}

		_%count @ IF
			_%point @ portC@ 
			1  _%point +!   \ we increment by one, these a codes not characters
			-1 _%count +!
			_#first_code_character - 
		ELSE
			_#exit_code
		THEN

		\ data (--
		_%point @ 
		_%count @
		ROT 
	;

String until the first charcter greater than 7F. The result is placed in the buffer as a $ counted string If the next character is a command the rusult is a null string. 

  
	: _=string { variable _%point variable _%count variable _%buffer -- ( addr count buffer)  }{
		variable _%out_pointer
		}  
		\ (--
		_%buffer @  _%out_pointer !
		#$count_length _%out_pointer +!   \ leave room for count
		\ We don't have to transfer all the string in one bite so 
		\ only transfer what will fit into the assigned buffer.
		_%count @ #$maximum_data MIN zero ?DO
			_%point @ portC@ DUP _#first_code_character < IF  \ char(--
				 _%out_pointer @ char!
				 1 CHARS _%out_pointer +!
				 1 _%point +!
				 -1 _%count +!
			ELSE  \ addr buffer (--
				DROP
				_%out_pointer @ #$count_length - _%buffer @ -    \ buffer bytes<-
				bytes>chars _%buffer @ $count!

				_%point @ 
				_%count @ 
				_%buffer @

				UNLOOP
				EXIT
			THEN
		LOOP  \ addr buffer (--
		
		_%out_pointer @ #$count_length - _%buffer @ -    \ buffer bytes<-
		bytes>chars _%buffer @ $count!

		_%point @
		_%count @ 
		_%buffer @

	;

Strings are extracted from the input buffer untill a control code is found. As the strings are moved to the output buffer they are padded dso the string count is always on a word boundry. The cont field after the last string is set to -1. 

 
	: _=label_string { variable _%point variable _%count variable _%buffer -- ( addr count buffer)  }{
		variable _%out_pointer
		variable _%loop_count
		}  
		\ (--
		_%buffer @ _%out_pointer !

		\ We can only transfer what will fit into the assigned buffer.
		\ We have to subtract #$count_length to leave room for the 
		\ label strings terminator ( a count of -1)
		_%count @ #$maximum_data #$count_length - bytes>chars MIN DUP _%loop_count ! 
		\ subtract from _%count we add what is left over back on
		NEGATE _%count +!
		
		BEGIN
			\ _%loop_count can go negative.
			\ It occues if a string that can't fit into the output buffer is removed.
			_%loop_count @ 0>
		WHILE
			_%point @ portC@ DUP _#first_code_character < IF  \ addr buffer char(--
				\ character is a string count, the rules say the whole string must be in the 
				\ buffer
				DUP _%out_pointer @ $count!
				#$count_length _%out_pointer +!   \ leave room for count
				1 _%point +!
				-1 _%loop_count +!
				\ the just read caracters give the amount to be transfered
				\ add buffer char(--
				DUP _%loop_count @ < IF
					DUP _%point @ + _%point @ DO
						I portC@ _%out_pointer @ char!
						1 CHARS _%out_pointer +!
					LOOP
					\ Move pointer up 
					DUP _%point +!
					\ subtract from _%loop_count
					NEGATE _%loop_count +!
					\ take buffer pointer to word boundry
					\ This is in the rules, the label strings are on a word boundry.
					_%out_pointer @ 1 + -2 AND _%out_pointer !
				ELSE 
					\ can't fit into output buffer remove from input buffer only
					\ This will make _%loop_count negate but the method of
					\ updating _%count will deal with that.
					DUP _%point +!
					NEGATE _%loop_count +!
				THEN
			ELSE  \ addr buffer char(--
				DROP 
				\ label strings have to be terminated with -1
				-1 _%out_pointer @ $count!
				\ add remaining _%loop_count to _%count to undo damage done when the
				\ whole value was subtracted
				_%loop_count @ _%count +!

				_%point @ 
				_%count @
				_%buffer @
				EXIT
			THEN
		REPEAT  \ addr buffer (--
		\ _%loop_count will be negatative if we couldn't fit the string in the output
		\ buffer, otherwise it will be zero if here.
		_%loop_count @ _%count +!
		\ If the count has gone negative something is very wrong just set it back to
		\ zero and be happy
		_%count @ 0< IF
			0 _%count !
		THEN

		_%point @ 
		_%count @ 
		_%buffer @

	;

The next character in input buffer is a byte parameter. 

 
	: _=c@ {  variable _%point variable _%count -- ( addr data)  }{
		}
		_%point @ portC@ 
		1 _%point +!   \ we increment by one, these a codes not characters
		-1 _%count +!
		\ data (--
		_%point @
		_%count @ 
		ROT
	;

The next two characters in input buffer is a word parameter. They are stored high byte low byte. The word can be on any byte boundry. 

 
	: _=w@ { variable _%point variable _%count -- ( addr data)  }{
		}

		zero
		2 0 DO
			8 LSHIFT
			_%point @ portC@ OR
			1 _%point +!   \ we increment by one, these a codes not characters
			-1 _%count +!
			_%count @ 0= IF
				UNLOOP
				_%point @ 
				_%count @ 
				ROT
				EXIT
			THEN
		LOOP

		\ data (--
		_%point @ 
		_%count @ 
		ROT
	;

The next two characters in input buffer is a long word parameter. They are stored high byte to low byte. The word can be on any byte boundry. 

  
	: _=@ { variable _%point variable _%count -- ( addr data)  }{
		}
		zero
		4 0 DO
			8 LSHIFT
			_%point @ portC@ OR
			1 _%point +!   \ we increment by one, these a codes not characters
			-1 _%count +!
			_%count @ 0= IF
				UNLOOP
				_%point @ 
				_%count @ 
				ROT
				EXIT
			THEN
		LOOP
		\ data(--
		_%point @ 
		_%count @
		ROT
	;

	\ 80h
	: _=exit ( addr count--addr 0)
		send ( flush type buffer to terminal) 
		DROP zero
	;

	\ 81h 
	: _=null ( addr count --addr count) 
	;

	\ 82h 
	: _=send ( addr count--addr count)
		send 
	;

	\ 83h 
	\ ####
	\ used in ilan to set the number of characters expected
	\ Allows a task to ask for expect characters.
	\ See SCONNECT and MCONNECT
	\ This is a bug. following code is correct.
	: _=end ( addr--addr)
		TRUE ABORT" Session finished"
	;

	\ 84h 
	: _=?data ( addr count--addr count)
		\ Use in ILAN
		TRUE =decode_?data !
	;

	\ 86h
	: _=!control ( addr count --addr count ) 
		_=c@  !control  
	;

	\ 87h 
	: _=!eot ( addr count --addr count)
		buffer _=string !eot 
	;

	\ 88h) 
	: _=!device ( addr count--addr count) 
		_=c@ ( !DEVICE ) DROP 
	;

	\ 89h 
	: _=baud ( addr count-- addr count)    
		_=@ baud 
	;

	\ 8Ah
	: _=mark ( addr count--addr count)
		buffer _=string COUNT MARK 
	;

	\ 8Bh 
	: _=tab  ( addr count--addr count)   
		_=c@ >R _=c@ R> TAB 
	;

	\ 99
	\ Abort returns buffers
	: _=abort  ( addr count--x)
		ABORT 
	;

	\ 9A
	: _=box ( addr count--addr count) 
		_=c@ >R _=c@ R> .BOX 
	;

	\ 9B
	: _=element { ( addr count--addr count) }{
		variable %temp1
		variable %temp2
		variable %temp3
		variable %temp4
		variable %temp5
		variable %temp6
		}
		\ The items come out of the buffer in the wrong order
		_=c@ %temp1 !
		_=c@ %temp2 !
		_=c@ %temp3 !
		_=c@ %temp4 !
		_=c@ %temp5 !
		_=c@ %temp6 !
		%temp6 @ %temp5 @ %temp4 @ %temp3 @ %temp2 @ %temp1 @ .ELEMENT 
	;

	\ 9C
	: _=line ( addr count--addr count )
		_=c@ >R _=c@ >R _=c@ 2R> 
		 .LINE
	;

	\ 9D
	: _=zed ( addr count --addr count)
		_=c@ >R _=c@ >R _=c@ 2R> SWAP .ZED
	;

	\ A9
	: _=labels  ( addr count--addr count )
		buffer _=label_string LABELS 
	;

	\ AA
	: _=shift_labels ( addr count --addr count )
		buffer _=label_string SHIFT_LABELS 
	;

	\ AF
	: _=fgnd ( addr count --addr count ) 
		_=c@ foreground 
	;

	\ B0
	: _=bgnd ( addr count--addr count) 
		_=c@ background
	;

	\ B1
	: _=border ( addr count --addr count) 
		_=c@ 
		BORDER ;

	\ AD
	: _=message ( add count--addr count)
		buffer _=string COUNT MESSAGE 
	;

	\ B2
	: =?????? ( addr count--x)
		buffer 10 DUMP  ." <- Last string."
		OVER 40 - 60 DUMP ." <-within this."
		user_base .h     ." <- user_base"  send
		TRUE ABORT" Unknown character in a decode string" 
	;

	\ entries have the stack effect ( addr count-- addr count)
	\ flag is true if the decode is to terminate. 
	CREATE decode_table
	0 tw,
	' _=exit          t, \ 80
	' _=null          t, \ 81
	' _=send          t, \ 82
	' _=end           t, \ 83
	' _=?data         t, \ 84
	' clear           t, \ 85
	' _=!control      t, \ 86
	' _=!eot          t, \ 87
	' _=!device       t, \ 88
	' _=baud          t, \ 89
	' _=mark          t, \ 8A
	' _=tab           t, \ 8B
	' PAGE            t, \ 8C
	' CR              t, \ 8D
	' >|              t, \ 8E
	' |>              t, \ 8F
	' |I              t, \ 90
	' |O              t, \ 91
	' |V              t, \ 92
	' |H              t, \ 93
	' |N              t, \ 94
	' |TL             t, \ 95
	' |TR             t, \ 96
	' |BL             t, \ 97
	' |BR             t, \ 98
	' _=abort         t, \ 99
	' _=box           t, \ 9A
	' _=element       t, \ 9B
	' _=line          t, \ 9C
	' _=zed           t, \ 9D
	' normal          t, \ 9E
	' rev             t, \ 9F
	' blink           t, \ A0
	' dim             t, \ A1
	' udl             t, \ A2
	' dim&blink       t, \ A3
	' rev&blink       t, \ A4
	' rev&dim         t, \ A5
	' rev&udl         t, \ A6
	' rev&dim&blink   t, \ A7
	' rev&dim&udl     t, \ A8
	' _=labels        t, \ A9
	' _=shift_labels  t, \ AA
	' CURSOR          t, \ AB
	' NO_CURSOR       t, \ AC
	' _=message       t, \ AD
	' NO_MESSAGE      t, \ AE
	' _=fgnd          t, \ AF
	' _=bgnd          t, \ B0
	' _=border        t, \ B1
	' =??????         t, \ B2

	HERE decode_table - 4/ decode_table TW!
	 
 
	\ we have a small problem, the buffer may be in dual port memory
	\ and dual port memory only supports word reads.
	: _(cvs_decode) ( addr count --)
		BEGIN 
			DUP 0> 
		WHILE
			buffer _=string portC@ IF
			   buffer COUNT TYPE
			ELSE 
				_=command 
				decode_table vector
			THEN
		REPEAT
		2DROP
	;

	: _cvs_terminal_codes_decode ( addr number --)
		$buffer  
			_(cvs_decode) 
		kill_buffer 
	;
./version081/_do_code.html0100777000000000000000000000316007300314345014257 0ustar rootroot COLDFORTH KERNEL license 
     

    | CODE _do_create
		R )+ W MOV
        W S -) MOV   
	NEXT
    

	| CODE _do_does>   
    	R )+ A0 MOV
		R )+ W MOV
		W S -) MOV   
    	A0 R -) MOV   
    NEXT
    
    
	\    jsr -> _do_loop
	\    offset 2 bytes
    | CODE _do_loop ( --)
		R )+ W MOV
    	1 # R ) ADD   
    	R ) D0 MOV  
    	4 R) D0 CMP  CS IF
    		W ) A0 W. MOV   
    		A0 W ADD
			W R -) MOV   
    		NEXT assembler
    	THEN   
    	2 # W ADD   
    	8 # R ADD 
		W R -) MOV  
    NEXT
    
	\    jsr -> _do_+loop
	\    offset 2 bytes
    | CODE _do_+loop ( n--)
		R )+ W MOV
    	S )+ D1 MOV      
    	D1 R ) ADD   
    	R ) D0 MOV
    	4 R) D0 SUB  
    	D1 D0 EOR   MI IF
			W ) A0 W. MOV
			A0 W ADD
    		W R -) MOV  
    		NEXT assembler
    	THEN  
    	2 # W ADD  
    	8 # R ADD
		W R -) MOV   
    NEXT
    
	\ jsr -> _do_>do
	\ offset 2 bytes
    | CODE _do_?do ( limit start --)
		R )+ W MOV
		S )+ D0 MOV
		S )+ D1 MOV
    	D0 D1 CMP NE IF
			D1 R -) MOV
			D0 R -) MOV
    		2 # W ADD
			W R -) MOV
    	ELSE
			W ) A0 W. MOV
			A0 W ADD
    		W R -) MOV 
    	THEN 
    NEXT

	\ jsr -> _do_do
	| CODE _do_do
		R )+ W MOV
		S )+ D0 MOV
		S )+ R -) MOV
		D0 R -) MOV
		W R -) MOV
	NEXT
./version081/abort.html0100777000000000000000000002444607300314345013645 0ustar rootroot COLDFORTH KERNEL license 
 

   	: dot"  ( --)
		TRUE ?R@ 
		$type 
	;

    forth : ."  ( --)
		HOST COMPILE dot" ," ; TARGET



    CREATE (return_error) 0 t,
	CREATE (assembler>dict) 0 t,
	CREATE (create) 0 t,
	CREATE (closes) 0 t,
    
    
	\ ---------------------------------------------------------------------
	\ Finishing local dictionary
	\ Needed by abort
	\ ---------------------------------------------------------------------
	\ local dictionary
	\ Created with { -- }{ } 
	\ removed on ;

	: _exit_local_dictionary
			previous_definitions
			_'h_local_old_mode @  _'h_mode !  \ (--
			_'h_local_old_'top> @ _'h_top> ! 
			_'h_local_old_'h> @ _'h>      !
	;

	: _end_local_dictionary
		\ remove vocabulary from vocabulary list
		_'h_local_wid @ IF
			_'h_local_wid @
			[ _#voc_link _#voc_wid - ]T LITERAL + unlink_double
			\ indicate it is gone
			zero _'h_local_wid !
		THEN
		_'h_local_base @ IF
			\ return buffer
			_'h_local_base @ FREE DROP ( FREE never fails)
			\ indicate it has been done
			zero _'h_local_base !
		THEN
	;


    
    CODE abort

	\	_%task_table U) A0 MOV
		_%data_stack_end U) S MOV
		S -) CLR

		_%return_stack_end U) R MOV	
		(return_error) AB R -) MOV
		
		xclock+ AB D0 MOV
		D0 _task_restart_time U) MOV
    
		'abort_file U) 'input_file U) MOV
		'abort_file U) 'output_file U) MOV

		\ Set back to interpreting
		FALSE # STATE U) MOV

		\ default create word
		(create) AB D0 MOV
		D0 'create U) MOV
      
		\ vector to ,ABORT
		'abort U) W MOV  
		WVECTOR
 

	CREATE _(close_included_files)
		0 t, 
	

	CREATE (.S) 0 t,
	: .S (.S) @execute ;

	CREATE (dump) 0 t,
	: DUMP (dump) @execute ;

	: _abort_action ( --)
		\ tidy up compilation pointers
		\ .S ." tidy up compilation pointers"
		_'h_task  _'h>  !
		_'h_task_top _'h_top> !
		_#dictionary_code _'h_mode !

		\ This has to occure before abort buffers are returned
		\ because a local dictionary has a vocabulary link into
		\ the system vocabulary list. This has to be unlinked first.
		\ .S ." finish local dictionary"
		_%local_use @ IF
			_end_local_dictionary
		THEN  

		\ zero dictionary buffer pointers
		\ Return abort buffers
		\ .S ." return abort buffers"
		_return_abort_buffers

		\ 
		\ Return buffers claimed with get_buffer
		\ .S ." return get buffers"
		_return_buffers

		(assembler>dict) @execute

		\ .S ." close included files"
		_(close_included_files) @execute

		\ don't use old catch
		\ This shouldn't be required.
		\ .S ." reset error handler"
		zero handler !
		\ .S ." about to abort"
		abort 
	;  RECOVER
    
    
    CREATE (error_position) 0 t,
    
    
    
	
	CREATE _$no_reason ," No reason for abort given"
    
	: _abort"_action ( $--)
		\ If zero we were not given a reason
		DUP not IF
			DROP _$no_reason
		THEN
    	'abort_file  @ 'output_file !  ( select error path)
    	_error_pos? W@ IF  ( don't suppress error strings)
			%line @  IF  ( loading from file save position)
				(error_position) @execute
			THEN
			seal W@ not IF
				ONLY 
				FORTH DEFINITIONS 
			ELSE
				ONLY
				&COMMANDS DEFINITIONS
			THEN
			CR 
			\ _token COUNT ~TYPE
			SPACE $type send 
		THEN
		_abort_action
	;
ANS 9.6.1.2275 THROW

EXCEPTION

( k*x n -- k*x | i*x n )

If any bits of n are non-zero, pop the topmost exception frame from the exception stack, along with everything on the return stack above that frame. Then restore the input source specification in use before the corresponding CATCH and adjust the depths of all stacks defined by this Standard so that they are the same as the depths saved in the exception frame (i is the same number as the i in the input arguments to the corresponding CATCH), put n on top of the data stack, and transfer control to a point just after the CATCH that pushed that exception frame.

If the top of the stack is non zero and there is no exception frame on the exception stack, the behavior is as follows:

If n is minus-one (-1), perform the function of 6.1.0670 ABORT (the version of ABORT in the Core word set), displaying no message.

If n is minus-two, perform the function of 6.1.0680 ABORT" (the version of ABORT" in the Core word set), displaying the characters ccc associated with the ABORT" that generated the THROW.

Otherwise, the system may display an implementation-dependent message giving information about the condition associated with the THROW code n. Subsequently, the system shall perform the function of 6.1.0670 ABORT (the version of ABORT in the Core word set).

If THROW is executed with a non zero argument, the effect is as if the corresponding CATCH had returned it. In that case, the stack depth is the same as it was just before CATCH began execution. The values of the i*x stack arguments could have been modified arbitrarily during the execution of xt. In general, nothing useful may be done with those stack items, but since their number is known (because the stack depth is deterministic), the application may DROP them to return to a predictable stack state.

Typical use: 

 
: could-fail ( -- char )
    KEY DUP [CHAR] Q =  IF  1 THROW THEN ;

: do-it ( a b -- c)   2DROP could-fail ;

: try-it ( --)
    1 2 ['] do-it  CATCH  IF ( x1 x2 )
        2DROP ." There was an exception" CR
    ELSE ." The character was " EMIT CR
    THEN
	send
;

: retry-it ( -- )
    BEGIN  1 2 ['] do-it CATCH  WHILE
       ( x1 x2) 2DROP  ." Exception, keep trying" CR
    REPEAT ( char )
    ." The character was " EMIT CR
	send
;

\ we assume codes are not within valid address ranges
-1  _prom_kernel_start  _prom_kernel_end WITHIN ??
-1 _#sdram0_base _#sdram0_base _#sdram0_size + WITHIN ??
-1 _#sdram1_base _#sdram1_base _#sdram1_size + WITHIN ??

These are not used within the kernel but are needed if a standard program throws one of the defined error codes. 

 
	CREATE _abort_strings
	( 000 ) 	," Not an abort"    
	( -01 )		," ABORT"
	( -02 )		," ABORTquote"
	( -03 )		," stack overflow"
	( -04 )		," stack underflow"
	( -05 )		," return stack overflow"
	( -06 )		," return stack underflow"
	( -07 )		," do-loops nested too deeply during execution"
	( -08 )		," dictionary overflow"
	( -09 )		," invalid memory address"
	( -10 )		," division by zero"
	( -11 )		," result out of range"
	( -12 )		," argument type mismatch"
	( -13 )		," undefined word"
	( -14 )		," interpreting a compile-only word"
	( -15 )		," invalid FORGET"
	( -16 )		," attempt to use zero-length string as a name"
	( -17 )		," pictured numeric output string overflow"
	( -18 )		," parsed string overflow"
	( -19 )		," definition name too long"
	( -20 )		," write to a read-only location"
	( -21 )		," unsupported operation (e.g., AT-XY on a too-dumb terminal)"
	( -22 )		," control structure mismatch"
	( -23 )		," address alignment exception"
	( -24 )		," invalid numeric argument"
	( -25 )		," return stack imbalance"
	( -26 )		," loop parameters unavailable"
	( -27 )		," invalid recursion"
	( -28 )		," user interrupt"
	( -29 )		," compiler nesting"
	( -30 )		," obsolescent feature"
	( -31 )		," >BODY used on non-CREATEd definition"
	( -32 )		," invalid name argument (e.g., TO xxx)"
	( -33 )		," block read exception"
	( -34 )		," block write exception"
	( -35 )		," invalid block number"
	( -36 )		," invalid file position"
	( -37 )		," file I/O exception"
	( -38 )		," non-existent file"
	( -39 )		," unexpected end of file"
	( -40 )		," invalid BASE for floating point conversion"
	( -41 )		," loss of precision"
	( -42 )		," floating-point divide by zero"
	( -43 )		," floating-point result out of range"
	( -44 )		," floating-point stack overflow"
	( -45 )		," floating-point stack underflow"
	( -46 )		," floating-point invalid argument"
	( -47 )		," compilation word list deleted"
	( -48 )		," invalid POSTPONE"
	( -49 )		," search-order overflow"
	( -50 )		," search-order underflow"
	( -51 )		," compilation word list changed"
	( -52 )		," control-flow stack overflow"
	( -53 )		," exception stack overflow"
	( -54 )		," floating-point underflow"
	( -55 )		," floating-point unidentified fault"
	( -56 )		," QUIT"
	( -57 )		," exception in sending or receiving a character"
	( -58 )		," [IF], [ELSE], or [THEN] exception"
		-1 t,

	: abort_code>$ { ( code -- $) }{
		variable %current_code }
		NEGATE 
		0 %current_code !
		_abort_strings
		BEGIN
			\ code addr (--
			OVER %current_code @ = IF
				NIP 
				EXIT
			THEN
			COUNT DUP $FF = IF
				DROP 2DROP zero EXIT
			THEN
			+ ALIGNED
			1 %current_code +!
		AGAIN
	;

	-#58 CONSTANT _#last_abort_code

COLDFORTH Aborts supply an address to an error string. If you want to recover from a particular error find the address of the string and compare. 

 
	CODE _throw       ( n -- )
		S )+ D0 MOV
		handler U) R MOV
		R )+ handler U) MOV
		R )+ S MOV
		\ local variable pointer
		R )+ LP MOV
		\ object pointer
		R )+ OP MOV
		D0 S -) MOV
	NEXT

	\ System assumes non zero value is a string except for
	\ -1  to _#last_abort_code which are standard ANSI abort codes
	: THROW ( n --)
		\ .S ." into THROW"
		\ There ar no problems
		DUP not IF 
			DROP EXIT 
		THEN
		\ There are problems and someone has done a CATCH
		handler @ IF
			\ .S ." about to _throw"
			\ handler @ $20 DUMP

			_throw
			EXIT
		THEN
		\ No CATCH sort it out now.
		\ n(--
		DUP -1 = IF \ ABORT
			\ There is no string
			_abort_action
		THEN
		DUP _#last_abort_code zero WITHIN IF 
			\ User threw with a ANSI standard abort code.
			abort_code>$
		THEN
		\ .S ." about to do _abortquote_action"
		_abort"_action
	;
							
	
	: $ABORT  ( $ --)
		?DUP IF
			THROW
		THEN
	; 

	' $ABORT ($abort) t!
./version081/abort_buffer.png0100777000000000000000000001501107300314345015002 0ustar rootrootPNG  IHDR wKPLTE@ ` @ @@@`@@@@@` `@``````` @` @` @` @`@ @@@`@@@@@ @ @@ @` @ @ @ @ @@@ @@@@@`@@@@@@@@@@`@ `@@`@``@`@`@`@`@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@@ @@@`@@@@@ @` @ ` @ @@@`@@@@@` `@``````` @` @`ࠀ @` @` @` @ ` @ @@@`@@@@@` `@``````` @` @` @`𠠤X4DIDATx흍 F}9D Fтzt%)>pCՄjnVQpQpQPY7sh[ܾmGa(=Apu熿~-ޯ\G3H&R ~$A?mjtZ/S^ޚ(j4B7nO=`j`#3 V) g h51Mw4g%|,i==<7G, ' p f?N=Qca\^GaL2W⚸`cL/XBN$Q'|\۔۠0&d`\ucz@M 2gNe Q[e AZ2CkMŕ9 `KP(_I790 1QdvgygzjB2AY-Q9 RP>T&sb혁n$Kf*r㜀Bn7X8g$yB#Y>у#QڥuL" !Ә 1a(7=%_G}N2VH֜,aA 0X4hS{xw:{3s2scB%=Ȥ+lfA 2xo"s7&2xo"s7&2GFP@ C/ w [Vf{]jNIDsy,X<J75d|@%C`諥)dgin_Gs/YvS'؝AH\okrrWw6#P0ςJf߃mJ*sxśs@7+s2QW8AV{q2 jG,PXԽ 32%> \(e: $9 j/BY0AN(|QE&x|9nU>\E;%P@[ʕw{|B9=, 0^5JW*\ ,Azh)ۻ酂= aj ~=F6ckKg#I8ODѰ+@r1(F='4E&b &I %y댬+hz'$ .r },/n drwma!d{ LĴIZF}  Q5oL_y@TNόdd # e]\6G,Swc$#BY F2(e: Gy(G/0V,LE|+Q{d: Gy(Gp!V[}MN3. c~z(eҕz :B#'l"($d$/FɔΌ.LL*Wq#)TL+-z \ԞY>a$#;WX/_301P@703P$S <ԣc%z'+tDA11BCPF9&+vg+Kˣ'Ǎ fxB !I!}yd >aU-v%{>>ۄ4KU(Bp-࿟5zU~VBȣ4G!s8Ê,}|+|Yf еB# #D>i񍀣P1NIm-ؠP^oP߄‰{d: Gy(G`ܣpCgѲ0#`jޜlEk@3"lD!ޥ-PG!Qд@ƒmnt[K#ܑƛ(sg)@Vq i.NaȼD?hFִK2Ru] Lk)J Wot?5B|{(A!ƧI*;ZLԞ̵f.0 >uMO7»P q@ Q0E!GlisB}+\ m(PkӓRB!̱ w^SxX!=*ߧp2tDWHjmJcOg:B:};Iɩ!V+5 xWvٯK61pG6X`&Q  6,#F  E_Wϩ X !>4(t(UDoQ; uy0>1σ'Q@i;taX|ߓQ: [b0010?Zi$#Y p\(*rK 6Xq)ʚ_:W?֕ ObTm J<%F6< jA]=`XsX!.1!FA$3 ;HG=MN@!5~ e6i$#}2ZpFTm|Fʜ8YYmBYp|3 H>V@G+ Ry2>\~9w ۹7u=UMjAųt2"҂㴒/m՚=UxP# (ur#cQ: YZ 1C$XczJ(Lbdx ]PͲYWm}¾ZLXdT<4Vńu-1f ttm*#Z^"ˈ׌ pl.Whuvx3G!# 9 yas ]^Z7ZL 0G(Xb ZL§-]I~wlI?oGPjĝ`+@;h,.$9 6-_ >&~T]jmK6 |k9P~;dZ{`!+y@ּȺ&m# B~pbj8XxVDaTERճoSg cǩF}WY8fS"3IB˒s95A2(\No *O _`a3&8sso<jB{QY5GM0n;GkFSpSѧ!B{Cʵ'pRY\x|(PwY!BASD?3@0 i pT|b= C}X|<6c\;P@ωqȺBwp4/c&ydR5V}|<6YbR~QiCiGێO6 Qi?IB"Mo(xJ𽭈Osd潂-&Qń9 0G(XbŠ(|Qi%>9 6-W͈?fQP+sF COLDFORTH KERNEL

< should be encoded as < in a html file, and > should be encoded as > 

 
: < < ; inline
: > > ; inline
: <> <> ; inline
: U> U> ; inline
: DU< DU< ; inline
: 0< 0< ; inline
: >> 0> ; inline
./version081/ansi_code_words.html0100777000000000000000000012351607300314345015676 0ustar rootroot COLDFORTH KERNEL

Standard words written in assembler, support subroutines

license
(um/mod)

Subroutines needed by standard words if processor doesn't support a divide. I think this is the best you can do.

Input
D0 is numi high
D1 is numi low
D2 domi
Use
Register D3 used
Output
D1 is quotent
D0 is remainder

Funny how things change, on a processor like the coldfire it is better to loop than unwind the code as memory access is slow. 

 
	\ Algoritham supplied by FORTH inc.
	\ leave the head on basic 64/32 divide is very useful.
	\ pity the processor didn't provide it.
	\ LABEL (um/mod)
	\   D3 R -) MOV
	\	0 # A0 MOV             \ 32 bits thru the loop
	\	BEGIN                  \
	\		D1 D1 ADDX         \ d1 left one bit,
	\		D0 D0 ADDX         \ and propagate msb of d1 when shifting d0
	\		CS IF              \ d0 shifted out a one,
	\			D2 D0 SUB      \ reduce d0 by d2 (divisor)
	\			D3 D3 SUB      \ generate phony X bit for next d1 shift
	\		ELSE               \ if no zero out of dshift
	\			D2 D0 SUB      \ try to reduce d0 by divisor
	\			CS IF          \ if fails,
	\				D2 D0 ADD  \ add divisor back
	\			THEN           \
	\		THEN               \
	\		                   \ Doing it this way result in a test that doesn't effect
	\		                   \ the x bit. I didn't see this FORTH inc did
	\		1 0) A0 LEA        \ repeat, 32 times
	\		$20 # A0 CMP       \
	\	EQ UNTIL               \
	\	D1 D1 ADDX             \ final shift for return value
	\	-1 # D1 EOR            \ and compliment, since we used inverted logic
	\   R )+ D3 MOV
	\ RTS

	\ 
	\ Faster version Thanks to: 
	\ Wayne Deeter wrd@logical-co.com
	\ D2 divisor
	\ D0 hi
	\ D1 low          
	\ output
	\ D1 quot
	\ D0 rem
	\ 	
	LABEL (um/mod) 
		D3 R -) MOV
		D4 R -) MOV
		D5 R -) MOV
		D2 D3 MOV
		1 # D3 LSR
		D2 D3 SUB  \ divisor/2
		A0 A0 SUB
		D3 A0 SUB  
		$1F # D5 MOV
		D2 D4 MOV
		D5 D4 LSL
		BEGIN
			D4 D1 ADD
			D3 D0 ADDX
			D3 CC SCC
			D1 D1 ADDX \ low
			D0 D0 ADDX \ upp
			D3 EXTB
			D2 D3 AND
			A0 D3 SUB
			1 # D5 SUB
		LT UNTIL
		D3 TST
		PL IF
			D2 D0 ADD
		THEN
		R )+ D5 MOV
		R )+ D4 MOV
		R )+ D3 MOV
	NEXT

	\ sub so return address
	(um/mod) CONSTANT (um/mod)

Standard words written in assembler



	??HEX
ANS 6.1.0010 !

( x a-addr -- )

Store x at a-addr. 

    

	CODE ! ( 32b addr --)
		S )+ A0 MOV   
		S )+ A0 ) MOV   
	NEXT inline
ANS 6.1.0090 *

( n1|u1 n2|u2 -- n3|u3 )

Multiply n1|u1 by n2|u2 giving the product n3|u3. 


		    
	CODE * ( n n - p)
		S )+ D1 MOV
		S ) D1 L. MULS
		D1 S ) MOV  
	NEXT inline
ANS 6.1.0120 +

( n1|u1 n2|u2 -- n3|u3 )

Add n2|u2 to n1|u1, giving the sum n3|u3. 


		    
	CODE + ( n n -n)   
		S )+ D0 MOV   
		D0 S ) ADD   
	NEXT inline
ANS 6.1.0130 +!

( n|u a-addr -- )

Add n|u to the single-cell number at a-addr. 

    

	CODE +! ( n|u addr--)
		S )+ A0 MOV   
		S )+ D0 MOV   
		D0 A0 ) ADD  
	NEXT inline
ANS 6.1.0160 -

( u1|n1 n2|u2 -- n3|u3)

Subtract n2|u2 from n1|u1, giving the difference n3|u3. 

    

	CODE - ( u1|n1 n2|u2 -- n3|u3) 
		S )+ D0 MOV   
		D0 S ) SUB   
	NEXT inline
ANS 6.1.0240 /MOD

CORE

( n1 n2 -- n3 n4 )

Divide n1 by n2, giving the single-cell remainder n3 and the single-cell quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM . 



	CODE /MOD  ( numi domi -- rem quot)
		S )+ D0 MOV
		S ) D1 MOV
		D0 D2 D1 REMS 
		D0 D1 L. DIVS
		D2 S ) MOV
		D1 S -) MOV 
	NEXT
8.6.1.1830 M+

m-plus DOUBLE

( d1|ud1 n -- d2|ud2 )

Add n to d1|ud1, giving the sum d2|ud2. 



	CODE M+  ( d1|ud1 n -- d2|ud2 )
		S )+ D2 MOV \ n
		S )+ D1 MOV \ dhigh
		S )+ D0 MOV \ dlow
		0 # D3 MOV
		D2 D0 ADD
		D3 D1 ADDX
		D0 S -) MOV
		D1 S -) MOV
	NEXT
ANS 6.1.0230 /

CORE

( n1 n2 -- n3 )

Divide n1 by n2, giving the single-cell quotient n3. An ambiguous condition exists if n2 is zero. If n1 and n2 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R S>D R> FM/MOD SWAP DROP or the phrase >R S>D R> SM/REM SWAP DROP . 



	CODE / ( n1 n2 -- n3)
		S )+ D0 MOV
		S )+ D1 MOV
		D0 D1 L. DIVS 
		D1 S -) MOV 
	NEXT
6.1.1561 FM/MOD

f-m-slash-mod CORE

( d1 n1 -- n2 n3 )

Divide d1 by n1, giving the floored quotient n3 and the remainder n2. Input and output stack arguments are signed. An ambiguous condition exists if n1 is zero or if the quotient lies outside the range of a single-cell signed integer. 

		Numi            Domi
		Dividend        Divisor Remainder       Quotient
		--------        ------- ---------       --------
		10                 7       3                1
		-10                7       4               -2
		10                -7      -4               -2
		-10               -7      -3                1
		
 

	CODE FM/MOD  ( numil numih domi -- rem quot )
		S )+ D2 MOV \ domi 
		MI IF
			D2 NEG  \ domi is now positive
			S )+ D0 MOV \ high numi
			S )+ D1 MOV \ low numi
			D0 TST
			MI IF
				D1 NEG  \ numi is now positive
				D0 NEGX
				(um/mod) BSR
				( domi - remainder -)
				D0 NEG
			ELSE
				(um/mod) BSR
				( domi - remainder -)
				( And if rem non zero round down for floored division)
				D0 TST  NE IF
					D2 D0 SUB
					1 # D1 ADD
				THEN
				D1 NEG  
			THEN
		ELSE
			S )+ D0 MOV  \ high numi
			S )+ D1 MOV  \ low numi 
			D0 TST
			MI IF
				D1 NEG
				D0 NEGX
				(um/mod) BSR
				( If rem non zero round down for floored division)
				( we add to D1 about to negate it)
				D0 TST  NE IF
					D2 D0 SUB
					D0 NEG
					1 # D1 ADD
				THEN
				( quotent is negative if numi and domi are oppersate signs)
				D1 NEG
			ELSE
				(um/mod) BSR
			THEN
		THEN
		D0 S -) MOV  ( remainder)
		D1 S -) MOV  ( quotent)
	NEXT
ANS 6.1.2214 SM/REM

( d1 n1 -- n2 n3 )

Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. Input and output stack arguments are signed. An ambiguous condition exists if n1 is zero or if the quotient lies outside the range of a single-cell signed integer. 

		 Numi            Domi
		 Dividend        Divisor Remainder       Quotient
		 --------        ------- ---------       --------
		 10                 7       3                1
		 -10                7      -3               -1
		 10                -7       3               -1
		 -10               -7      -3                1
		

		    
	CODE SM/REM  ( numil numih domi -- rem quot )
		S )+ D2 MOV \ domi 
		MI IF
			D2 NEG  \ domi is now positive
			S )+ D0 MOV \ high numi
			S )+ D1 MOV \ low numi
			D0 TST
			MI IF
				D1 NEG  \ numi is now positive
				D0 NEGX
				(um/mod) BSR
				( remainder takes the sign of numi)
				D0 NEG
			ELSE
				(um/mod) BSR
				( quotent is negative if numi and domi are)
				( opersate signs)
				D1 NEG
			THEN
		ELSE
			S )+ D0 MOV  \ high numi
			S )+ D1 MOV  \ low numi 
			D0 TST
			MI IF
				D1 NEG
				D0 NEGX
				(um/mod) BSR
				( remainder takes the sign of numi)
				D0 NEG
				( quotent is negative if numi and domi are opppersate signs)
				D1 NEG
			ELSE
				(um/mod) BSR
			THEN
		THEN
		D0 S -) MOV  ( remainder)
		D1 S -) MOV  ( quotent)
	NEXT
ANS 6.1.0250 0<

CORE

( n -- flag )

flag is true if and only if n is less than zero. 



	CODE 0< ( n -flag)
		FALSE # D1 MOV   
		S ) TST   MI IF
    		TRUE # D1 MOV 
		THEN 
		D1 S ) MOV 
	NEXT
ANS 6.2.0260 0<>

CORE EXT

( x -- flag )

flag is true if and only if x is not equal to zero. 



	CODE 0<> ( n --flag)
		FALSE # D1 MOV
		S ) TST NE IF
    		TRUE # D1 MOV 
		THEN 
		D1 S ) MOV
	NEXT


\	TRUE -1 ??=
\	CODE 0<>  ( x -- flag)
\		S )+ D0 MOV
\		0 # D1 MOV
\		-1 # D0 ADD
\		D1 D1 SUBX
\		D1 S -) MOV
\	NEXT
ANS 6.1.0270 0=

CORE

( x -- flag )

flag is true if and only if x is equal to zero.

See:
INVERT ( x a-addr -- )
NEGATE ( x a-addr -- )

		 
	CODE 0= ( n --flag )
		FALSE # D1 MOV
		S ) TST EQ IF
    		TRUE # D1 MOV  
		THEN
		D1 S ) MOV
	NEXT
ANS 6.1.0330 2/

CORE

( x1 -- x2 )

x2 is the result of shifting x1 one bit toward the least-significant bit, leaving the most-significant bit unchanged. 



	CODE 2/ ( x1 -- x2 )
		S )+ D0 MOV
		1 # D0 ASR
		D0 S -) MOV
	NEXT
ANS 6.1.0370 2DROP

CORE

( x1 x2 -- )

Drop cell pair x1 x2 from the stack. 


		    
	CODE 2DROP ( a b --)   
		8 # S ADD   
	NEXT inline
ANS 6.1.0380 2DUP

CORE

( x1 x2 -- x1 x2 x1 x2 )

Duplicate cell pair x1 x2. 


		    
	CODE 2DUP ( a b  -- a b a b )
		S ) \\ D0 D1 \\ MMOV
		D1 S -) MOV
		D0 S -) MOV    
	NEXT inline   \ It is 8 bytes, but allow for speed
ANS 6.1.0400 2OVER

CODE

( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )

Copy cell pair x1 x2 to the top of the stack. 


		    
	CODE 2OVER  ( a b c d -- a b c d a b)
		0C S) S -) MOV   
		0C S) S -) MOV    
	NEXT inline
ANS 6.1.0430 2SWAP

CORE

( x1 x2 x3 x4 -- x3 x4 x1 x2 )

Exchange the top two cell pairs. 

 
		   
	CODE 2SWAP ( a b c d  - c d a b )
		S )+ D0 MOV
		S )+ D1 MOV
		S )+ D2 MOV
		S )+ D3 MOV
		D1 S -) MOV
		D0 S -) MOV
		D3 S -) MOV
		D2 S -) MOV
	NEXT
ANS 6.1.0480 <

less-than CORE

( n1 n2 -- flag )

flag is true if and only if n1 is less than n2. 



	CODE < ( n n - flag)
		FALSE # D2 MOV   
		S )+ D0 MOV   
		S ) D1 MOV
		\ destination relative to source 
		D0 D1 CMP  LT IF
    		TRUE # D2 MOV 
		THEN  
		D2 S ) MOV 
	NEXT
ANS 6.1.0530 =

CORE

( x1 x2 -- flag )

flag is true if and only if x1 is bit-for-bit the same as x2. 


		     
	CODE = ( n n --flag)
		FALSE # D2 MOV  
		S )+ D0 MOV
		S )  D0 SUB
		EQ IF
    		TRUE # D2 MOV    
		THEN   
		D2 S ) MOV   
	NEXT  inline \ critical word in search_thread
ANS 6.1.0540 >

CORE

( n1 n2 -- flag )

flag is true if and only if n1 is greater than n2. 



	CODE > ( n n - flag)
		FALSE # D2 MOV   
		S )+ D0 MOV
		S ) D1 MOV  
		\ destination relative to source 	 
		D0 D1 CMP GT IF
			TRUE # D2 MOV 
		THEN  
		D2 S ) MOV 
	NEXT
ANS 6.1.0630 ?DUP

CORE

( x -- 0 | x x )

Duplicate x if it is non-zero. 



	CODE ?DUP ( n - 0| n n)
		S ) TST NE  IF
			S ) S -) MOV    
		THEN   
	NEXT inline
ANS 6.1.0650 @

CORE

( a-addr -- x )

x is the value stored at a-addr. 


		   
	CODE @ ( addr -- 32b)
		S )+ A0 MOV   
		A0 ) S -) MOV   
	NEXT inline
ANS 6.1.0690 ABS

CORE

( n -- u )

u is the absolute value of n. 



	CODE ABS ( n --u)
		S ) D0 MOV MI IF   
			D0 NEG 
			D0 S ) MOV  
		THEN   
	NEXT inline
ANS 6.1.0720 AND

CORE

( x1 x2 -- x3 )

x3 is the bit-by-bit logical and of x1 with x2. 



	CODE AND ( 32b 32b - 32b)   
		S )+ D0 MOV   
		D0 S ) AND   
	NEXT inline
ANS 6.1.0850 C!

( char c-addr -- )

CORE

Store char at c-addr. When character size is smaller than cell size, only the number of low-order bits corresponding to character size are transferred. 


		   
	CODE C! ( n a)
		S )+ A0 MOV   
		S )+ D0 MOV
		D0 A0 ) B. MOV  
	NEXT inline
ANS 6.1.0870 C@

CORE

( c-addr -- char )

Fetch the character stored at c-addr. When the cell size is greater than character size, the unused high-order bits are all zeroes. 


#5407 [IF]
	CODE C@ ( addr --n)
		S )+ A0 MOV  
		A0 ) D0 B. MVZ
		D0 S -) MOV   
	NEXT inline   
[ELSE]
	CODE C@ ( addr --n)
		S )+ A0 MOV  
		0 # D0 MOV 
		A0 ) D0 B. MOV
		D0 S -) MOV   \ 8 bytes but allow for speed
	NEXT inline  
[THEN]
ANS 6.1.1260 DROP

CORE

( x -- )

Remove x from the stack. 


		    
	CODE DROP ( 32b-)           
		4 # S ADD      
	NEXT inline
ANS 6.1.1290 DUP

( x -- x x )

Duplicate x.


		    
	CODE DUP ( 32b - 32b 32b)   
		S ) S -) MOV   
	NEXT inline
ANS 6.1.1370 EXECUTE

( i*x xt -- j*x )

Remove xt from the stack and perform the semantics identified by it. Other stack effects are due to the word EXECUTEd. 



	CODE EXECUTE  ( addr --)
		S )+ W MOV
		WVECTOR
ANS 6.1.1540 FILL

( c-addr u char -- )

If u is greater than zero, store char in each of u consecutive characters of memory beginning at c-addr. 



	CODE FILL ( a n c --)
		S )+ D2 MOV       \ low 8 bits
		S )+ D0 MOV EQ IF \ zero fill
				4 # S ADD
		ELSE \ data to move
			S ) A0 MOV \ addr
			D0 D1 MOV
			S )+ D1 OR
			03 # D1 AND NE IF ( have to use bytes)
				BEGIN
					D2 A0 )+ B. MOV
				1 # D0 SUB
				EQ UNTIL
			ELSE ( long words thanks)
				D2 D3 MOV
				8 # D2 ASL
				D3 D2 B. MOV
				8 # D2 ASL
				D3 D2 B. MOV
				8 # D2 ASL
				D3 D2 B. MOV
				BEGIN
					D2 A0 )+ MOV
				4 # D0 SUB
				EQ UNTIL
			THEN
		THEN
	NEXT
ANS 6.1.1680 I

Interpretation: Interpretation semantics for this word are undefined.

Execution: ( -- n|u ) ( R: loop-sys -- loop-sys )

n|u is a copy of the current (innermost) loop index. An ambiguous condition exists if the loop control parameters are unavailable. 



	CODE I    ( - 32b)
		4 R) S -) MOV   
	NEXT
ANS 6.1.1720 INVERT

( x1 -- x2 )

Invert all bits of x1, giving its logical inverse x2.

bit by bit invert, 1 complement
use NEGATE to get 2 complement
use 0= to convert from number to flag
use not to invert a flag.
See:
NEGATE ( x a-addr -- )
0= ( x a-addr -- )

	
	CODE INVERT  ( x1 -- x2 )
		S )+ D0 MOV
		-1 # D0 EOR
		D0 S -) MOV
	NEXT  inline
ANS 6.1.1730 J

Interpretation: Interpretation semantics for this word are undefined.

Execution: ( -- n|u ) ( R: loop-sys1 loop-sys2 -- loop-sys1 loop-sys2 )

n|u is a copy of the next-outer loop index. An ambiguous condition exists if the loop control parameters of the next-outer loop, loop-sys1, are unavailable. 

  

	CODE J    ( - 32b)   
		0C R) S -) MOV   
	NEXT
ANS 6.1.1805 LSHIFT

( x1 u -- x2 )

Perform a logical left shift of u bit-places on x1, giving x2. Put zeroes into the least significant bits vacated by the shift. An ambiguous condition exists if u is greater than or equal to the number of bits in a cell. 



	CODE LSHIFT ( x1 shift --)
		S )+ D0 MOV
		S )+ D1 MOV
		D0 D1 LSL
		D1 S -) MOV
	NEXT  inline  \ 8 bytes allow for speed
ANS 6.1.1810 M*

( n1 n2 -- d )

d is the signed product of n1 times n2. This word is a useful early step in calculation, going to extra precision conveniently. It has been in use since the Forth systems of the early 1970's.

We use 16 * 16 -> 32 as it gives a simple to follow solution.

Ax + B * Cx + D <=>
DB + BCx + DAx + ACxx <=>
ACxx + (DA+BC)x + DB
In this case x = 2**16


#USE_MAC [IF]
	\	stack usage

		zero
		DUP		EQU #{s}_sdm.n1
		DUP		EQU #{s}_sdm.rh				CELL+
		DUP		EQU #{s}_sdm.n2
		DUP		EQU #{s}_sdm.rl				CELL+
				EQU #{s}_sdm.stack_length


	\	Mac Constants

		0x06	EQU #sign_bit


	CODE M* ( N2 N1 --- Rl Rh )


		MACSR D0 MOV
		#sign_bit # D0 BSET
		D0 MACSR MOV

		D4 CLR

		[ #{s}_sdm.n1 S ] D0 MOV
		MI IF
			D0 NEG
			TRUE # D4 EOR
		THEN

		[ #{s}_sdm.n2 S ] D1 MOV
		MI IF
			D1 NEG
			TRUE # D4 EOR
		THEN

		zero # ACC MOV
		D0 D1 W. MAC					\ B*D = LH|LL
		ACC D2 MOV
		D2 [ #{s}_sdm.rl S ] MOV
		D2 W. CLR			 
		D2 SWP							\ D2  = 00|LH 
		D2 ACC MOV
		D0 U. D1 W. MAC					\ A*D + D2 = HL|LH + 00|LH 
		ACC D2 MOV						\ D2  = AD + BDh 
		zero # ACC MOV
		D0 D1 U. W. MAC					\ B*C = HL|LH 	
		ACC D3 MOV						\ D3  = BC 
		D3 D2 ADD						\ D2 = BC + AD + BDh ==> HL|LH 
		D2 [ #{s}_sdm.rl S ] W. MOV		\ LH complete and place with LL 	
		D3 CLR
		D3 D3 ADDX
		D3 D2 W. MOV					\ Place extend bit in LH 
		D2 SWP							\ D2 = HH extend only |HL 
		D2 ACC MOV
		D0 U. D1 U. W. MAC				\ A*C + D2 = HH|HL 
		ACC D2 MOV						\ D2 = HH|LL 
		D2 [ #{s}_sdm.rh S ] MOV		

		D4 TST
		NE IF
			D2 NEG
			[ #{s}_sdm.rl S ] D3 MOV
			D3 NEG
			D3 [ #{s}_sdm.rl S ] MOV
			NE IF
				0xFFFFFFFF # D2 ADD
			THEN
			D2 [ #{s}_sdm.rh S ] MOV		
		THEN
	NEXT

[ELSE]

	CODE  M* ( a b -- low high)
			1 # D6 MOV  
			S ) D0 MOV MI IF 
				D6 NEG 
				D0 NEG 
				D0 S ) MOV  
			THEN
			4 S) D0 MOV MI IF 
				D6 NEG 
				D0 NEG
				D0 4 S) MOV 
			THEN
			0 # D7 MOV

			0 S) D0 W. MOV   ( A)
			2 S) D1 W. MOV   ( B)
			4 S) D2 W. MOV   ( C)
			6 S) D3 W. MOV   ( D)

			D3 D4 MOV        ( D) 
			D1 D4 MULU       ( BD)
			D4 6 S) W. MOV   ( BD low bits)
			D4 W. CLR        ( saved on stack nothing more to do with calc)
			D4 SWP           ( BD high bits)
			D2 D5 MOV        ( C )
			D1 D5 MULU		 ( BC)
			D4 D5 ADD
			D7 D7 ADDX	     ( collect the carry)	 
			D0 D3 MULU       ( AD )
			D3 D5 ADD
			0 # D3 MOV  
			D3 D7 ADDX       ( collect the carry)
			D5 4 S) W. MOV   ( x bits )
			D7 D5 W. MOV 
			D5 SWP           ( xx bits)
			D0 D2 MULU		 ( AC)
			D2 D5 ADD 
			D5  S ) MOV      ( xx and xxx bits)
			D6 TST MI IF
				4 S) D0 MOV 
				S )  D1 MOV
				D0 NEG
				D1 NEGX
				D0 4 S) MOV
				D1 S )  MOV  
			THEN
		NEXT
[THEN]
ANS 6.1.1870 MAX

( n1 n2 -- n3 )

n3 is the greater of n1 and n2. 


	    
	CODE MAX ( n1 n2 - n3 )   
		S )+ D0 MOV   
		S ) D0 CMP GT IF
			D0 S ) MOV   
		THEN   
	NEXT inline \ 8 bytes allow for speed
ANS 6.1.1880 MIN

( n1 n2 -- n3 )

n3 is the lesser of n1 and n2. 



	CODE MIN ( n1 n2 - n3 )   
		S )+ D0 MOV   
		S ) D0 CMP LT IF
			D0 S ) MOV   
		THEN   
	NEXT inline \ 8 bytes allow for speed
ANS 6.1.1900 MOVE

( addr1 addr2 u -- )

If u is greater than zero, copy the contents of u consecutive address units at addr1 to the u consecutive address units at addr2. After MOVE completes, the u consecutive address units at addr2 contain exactly what the u consecutive address units at addr1 contained before the move. 



	CODE MOVE  ( from to num --)
		S )+ D0 MOV	NE IF 	\  ( data to move)
			S )+ A1 MOV
			S )+ A0 MOV
			\ should the null case add time to the general case.
			\ A0 A1 CMP EQ IF
			\ 	NEXT assembler
			\ THEN
			\ can take out the address check here for 5307 as long word moves do not
			\ have to be on longword boundries, however the rti1000 bus is not so 					
			\ kind. But then the user should not be using rti1000 
			\ byte alligned addresses
			D0 D1 MOV
 			3 # D1 AND EQ IF ( everything on a long word boundry)
				\ destination relative to source
				A0 A1 CMP HI IF \ move up in memory
					D0 A0 ADD
					D0 A1 ADD
					BEGIN
						A0 -) A1 -) MOV
					4 # D0 SUB
					EQ UNTIL
					NEXT assembler
				THEN \ move down in memory
				BEGIN
					A0 )+ A1 )+ MOV
					4 # D0 SUB
				EQ UNTIL
				NEXT assembler
			THEN  
			D0 D1 MOV
 			1 # D1 AND EQ IF ( everything on a word boundry)
				\ destination relative to source
				A0 A1 CMP HI IF \ move up in memory
					D0 A0 ADD
					D0 A1 ADD
					BEGIN
						A0 -) A1 -) W. MOV
					2 # D0 SUB
					EQ UNTIL
					NEXT assembler
				THEN \ move down in memory
				BEGIN
					A0 )+ A1 )+ W. MOV
				2 # D0 SUB
				EQ UNTIL
				NEXT assembler
			THEN  
			\ do it as a byte operations
			A0 A1 CMP HI IF \ move up in memory
				D0 A0 ADD
				D0 A1 ADD
				BEGIN
					A0 -) A1 -) B. MOV
				1 # D0 SUB
				EQ UNTIL
				NEXT assembler
			THEN \ move down in memory
			BEGIN
				A0 )+ A1 )+ B. MOV
				1 # D0 SUB
			EQ UNTIL
			NEXT assembler
		THEN  \ nothing to move
		8 # S ADD
	NEXT
ANS 6.1.1910 NEGATE

( n1 -- n2 )

Negate n1, giving its arithmetic inverse n2.

See:
INVERT ( x a-addr -- )
0= ( x a-addr -- ) 


	CODE NEGATE ( n - n)  
		S ) D0 MOV 
		D0 NEG
		D0 S ) MOV   
	NEXT  inline
ANS 6.1.1980 OR

( x1 x2 -- x3 )

x3 is the bit-by-bit inclusive-or of x1 with x2. 


		 
	CODE OR  ( 32b 32b - 32b)   
		S )+ D0 MOV   
		D0 S ) OR    
	NEXT  inline
ANS 6.1.1990 OVER

( x1 x2 -- x1 x2 x1 )

Place a copy of x1 on top of the stack. 



	CODE OVER ( 32b1 32b2 - 32b1 32b2 32b1)
		4 S) S -) MOV   
	NEXT  inline
ANS 6.1.2160 ROT

( x1 x2 x3 -- x2 x3 x1 )

Rotate the top three stack entries. 



	CODE ROT  ( 32b1 32b2 32b3 -- 32b2 32b3 32b1)
		S )+ D0 MOV
		S )+ D1 MOV
		S )+ D2 MOV
		D1 S -) MOV
		D0 S -) MOV
		D2 S -) MOV   
	NEXT
ANS 6.1.2162 RSHIFT

( x1 u -- x2 )

Perform a logical right shift of u bit-places on x1, giving x2. Put zeroes into the most significant bits vacated by the shift. An ambiguous condition exists if u is greater than or equal to the number of bits in a cell. 



	CODE RSHIFT ( x1 shift --)
		S )+ D0 MOV
		S )+ D1 MOV
		D0 D1 LSR
		D1 S -) MOV
	NEXT inline \ 8 bytes allow for speed.
ANS 6.1.2170 S>D

( n -- d )

Convert the number n to the double-cell number d with the same numerical value. 



	CODE S>D ( n -- dl dh )
		S ) D0 MOV MI IF
			\ negative sign extend.
			-1 # S -) MOV
		ELSE
			0 # S -) MOV
		THEN
	NEXT
ANS 6.1.2260 SWAP

( x1 x2 -- x2 x1 )

Exchange the top two stack items. 



	CODE SWAP ( 32b1 32b2 - 32b2 32b1)
		S )+ D0 MOV
		S )+ D1 MOV   
		D0 S -) MOV   
		D1 S -) MOV   
	NEXT  inline \ 8 bytes allow for speed
ANS 6.1.2340 U<

( u1 u2 -- flag )

flag is true if and only if u1 is less than u2. 


		 
	-1 TRUE ??=  
	CODE U< ( u1 u2 --flag )
		0 # D2 MOV
		S )+ D0 MOV         \ u2
		S )+ D1 MOV         \ u1
		D0 D1 SUB           \ u1 u2 - 
		D2 D2 SUBX          \ carry if u2 is greater=
							\ or u1 is less
		D2 S -) MOV
	NEXT
ANS 6.2.2350 U>

u-greater-than CORE EXT

( u1 u2 -- flag )

flag is true if and only if u1 is greater than u2. 



	-1 TRUE ??= 
	CODE U> ( u1 u2 --flag )
		0 # D2 MOV
		S )+ D0 MOV         \ u2
		S )+ D1 MOV         \ u1
		D1 D0 SUB           \ u1 u2 - 
		D2 D2 SUBX          \ carry if u1 is greater
							\ or u2 is less
		D2 S -) MOV
	NEXT
ANS 6.1.2360 UM*

CORE

( u1 u2 -- ud )

Multiply u1 by u2, giving the unsigned double-cell product ud. All values and arithmetic are unsigned. We use 16 * 16 -> 32 as it gives a simple to follow solution.

Ax + B * Cx + D <=>
DB + BCx + DAx + ACxx <=>
ACxx + (DA+BC)x + DB
In this case x = 2**16 


	CODE UM* ( a b -- low high)
		0 # D7 MOV

		0 S) D0 W. MOV   ( A)
		2 S) D1 W. MOV   ( B)
		4 S) D2 W. MOV   ( C)
		6 S) D3 W. MOV   ( D)

		D3 D4 MOV        ( D) 
		D1 D4 MULU       ( BD)
		D4 6 S) W. MOV   ( BD low bits)
		D4 W. CLR        ( saved on stack nothing more to do with calc)
		D4 SWP           ( BD high bits)
		D2 D5 MOV        ( C )
		D1 D5 MULU		 ( BC)
		D4 D5 ADD
		D7 D7 ADDX	     ( collect the carry)	 
		D0 D3 MULU       ( AD )
		D3 D5 ADD
		0 # D3 MOV  
		D3 D7 ADDX       ( collect the carry)
		D5 4 S) W. MOV   ( x bits )
		D7 D5 W. MOV 
		D5 SWP           ( xx bits)
		D0 D2 MULU		 ( AC)
		D2 D5 ADD 
		D5  S ) MOV      ( xx and xxx bits)
	NEXT
ANS 6.1.2370 UM/MOD

( ud u1 -- u2 u3 )

Divide ud by u1, giving the quotient u3 and the remainder u2. All values and arithmetic are unsigned. An ambiguous condition exists if u1 is zero or if the quotient lies outside the range of a single-cell unsigned integer. 



	 CODE UM/MOD ( low high domi -- rem quot )
		S )+ D2 MOV \ domi
		S )+ D0 MOV \ high
		S )+ D1 MOV \ low
		(um/mod) BSR
		D0 S -) MOV  ( remainder)
		D1 S -) MOV  ( quotent)
	NEXT
ANS 6.1.2380 UNLOOP

CORE

Interpretation: Interpretation semantics for this word are undefined.

Execution: ( -- ) ( R: loop-sys -- )

Discard the loop-control parameters for the current nesting level. An UNLOOP is required for each nesting level before the definition may be EXITed. An ambiguous condition exists if the loop-control parameters are unavailable. 

 
		Typical use: 
	
		: X  ...
	
			limit first DO
		
			   ... test IF ... UNLOOP EXIT THEN ...
	
			LOOP
		    ...
		;

UNLOOP allows the use of EXIT within the context of DO ... LOOP and related do-loop constructs. UNLOOP as a function has been called UNDO. UNLOOP is more indicative of the action: nothing gets undone -- we simply stop doing it. 



	CODE UNLOOP ( --)
		R )+ W MOV
		8 # R ADD
		W R -) MOV
	NEXT
ANS 6.1.2490 XOR

( x1 x2 -- x3 )

x3 is the bit-by-bit exclusive-or of x1 with x2. 



	CODE XOR ( 32b 32b - 32b)   
		S )+ D0 MOV   
		D0 S ) EOR   
	NEXT inline
ANS 6.2.0280 0>

CORE EXT

( n -- flag )

flag is true if and only if n is greater than zero. 


		 
	CODE 0> ( n -- flag)
		FALSE # D1 MOV 
		S ) TST GT IF
    		TRUE # D1 MOV  
		THEN 
		D1 S ) MOV  
	NEXT
ANS 6.2.0415 2R@

CORE EXT

Interpretation: Interpretation semantics for this word are undefined.

Execution: ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 )

Copy cell pair x1 x2 from the return stack. Semantically equivalent to R> R> 2DUP >R >R SWAP . 


		 
	CODE 2R@ ( -- x1 x2 )
		R )+ W MOV
		4 R) S -) MOV
		R ) S -) MOV
		W R -) MOV
	NEXT
ANS 6.2.0500 <>

CORE EXT

( x1 x2 -- flag )

flag is true if and only if x1 is not bit-for-bit the same as x2. 


		    
	CODE <> ( n n - flag )
		FALSE # D2 MOV   
		S )+ D0 MOV
		S ) D1 MOV   
		D0 D1 CMP NE IF
			TRUE # D2 MOV  
		THEN  
		D2 S ) MOV  
	NEXT
ANS 6.2.1350 ERASE

( addr u -- )

If u is greater than zero, clear all bits in each of u consecutive address units of memory beginning at addr. COLDFORTH: Coded for minimum branch delays on long word fill This could be written using FILL, but it is an important word so it has been left as code. 



	CODE ERASE ( a n --)
		S )+ D0 MOV NE IF 
			S )+ A0 MOV \ addr
			D0 D1 MOV
			03 # D1 AND EQ IF ( can use long)
				\ D1 already contains zero after the alignment test
				BEGIN
					D1 A0 )+ MOV
					4 # D0 SUB
				EQ UNTIL
				NEXT 
				assembler
			THEN
			01 # D1 AND EQ IF
				BEGIN
					D1 A0 )+ W. MOV
					2 # D0 SUB
				EQ UNTIL
				NEXT 
				assembler
			THEN
       		0 # D1 MOV
			BEGIN
				D1 A0 )+ B. MOV
				1 # D0 SUB
			EQ UNTIL
			NEXT
			assembler
		ELSE
			4 # S ADD
		THEN
	NEXT
ANS 6.2.1930 NIP

( x1 x2 -- x2 )

Drop the first item below the top of stack.


		    
	CODE NIP  ( 32b1 32b2 -- 32b2)   
		S )+ S ) MOV 
	NEXT inline
ANS 6.2.2030 PICK

( xu ... x1 x0 u -- xu ... x1 x0 xu )

Remove u. Copy the xu to the top of the stack. An ambiguous condition exists if there are less than u+2 items on the stack before PICK is executed. 0 PICK is equivalent to DUP and 1 PICK is equivalent to OVER. 



	CODE PICK ( n -- 32b )
		S )+ D0 MOV 
		[ S D0 4 ] S -) MOV  
	NEXT  inline
ANS 6.2.2150 ROLL

( xu xu-1 ... x0 u -- xu-1 ... x0 xu )

Remove u. Rotate u+1 items on the top of the stack. An ambiguous condition exists if there are less than u+2 items on the stack before ROLL is executed.

2 ROLL is equivalent to ROT, 1 ROLL is equivalent to SWAP and 0 ROLL is a null operation. 



	CODE ROLL
		[ S ]+ D0 MOV
		[ S D0 4 ] A0 LEA
		[ S D0 4 ] [ S -] MOV
		
		BEGIN
			[ A0 -] [ 4 A0 ] MOV
			1 # D0 SUB
		CS UNTIL
		\ remember never have anything on the stack 
		\ on the wrong side of the stack pointer.
		4 # S ADD
	NEXT
ANS 15.6.2.1015 CS-PICK

c-s-pick TOOLS EXT

Interpretation: Interpretation semantics for this word are undefined.

Execution: ( C: destu ... orig0|dest0 -- destu ... orig0|dest0 destu )( S: u -- )

Remove u. Copy destu to the top of the control-flow stack. An ambiguous condition exists if there are less than u+1 items, each of which shall be an orig or dest, on the control-flow stack before CS-PICK is executed.

If the control-flow stack is implemented using the data stack, u shall be the topmost item on the data stack.

The intent is to reiterate a dest on the control-flow stack so that it can be resolved more than once. For example: 


	
		\ Conditionally transfer control to beginning of loop
		\ This is similar in spirit to C's "continue" statement.

		: ?REPEAT  ( dest -- dest ) \ Compilation
		           ( flag -- )      \ Execution
			0 CS-PICK   POSTPONE UNTIL
		; IMMEDIATE

		: XX  ( -- ) \ Example use of ?REPEAT
			BEGIN
			...
			flag ?REPEAT  ( Go back to BEGIN if flag is false )
			...
			flag ?REPEAT  ( Go back to BEGIN if flag is false )
			...
			flag UNTIL    ( Go back to BEGIN if flag is false )
			...
		;

As the compile stack is the data stack, and as each item is two stack items, CS-PICK is equivilant to 2pick in this system. 



	CODE CS-PICK ( n -- 32b )
		S )+ D0 MOV
		1 # D0 ASL 
		[ 4 S D0 4 ] S -) MOV
		[ 4 S D0 4 ] S -) MOV  
	NEXT
ANS 15.6.2.1020 CS-ROLL

c-s-roll TOOLS EXT

Interpretation: Interpretation semantics for this word are undefined.

Execution: ( C: origu|destu origu-1|destu-1 ... orig0|dest0 -- origu-1|destu-1 ... orig0|dest0 origu|destu )( S: u -- )

Remove u. Rotate u+1 elements on top of the control-flow stack so that origu|destu is on top of the control-flow stack. An ambiguous condition exists if there are less than u+1 items, each of which shall be an orig or dest, on the control-flow stack before CS-ROLL is executed.

If the control-flow stack is implemented using the data stack, u shall be the topmost item on the data stack. 



	CODE CS-ROLL
		[ S ]+ D0 MOV
		1 # D0 ASL
		[ S D0 4 ] A0 LEA
		[ 4 S D0 4 ] [ S -] MOV
		[ 4 S D0 4 ] [ S -] MOV
		1 # D0 ADD
		BEGIN
			[ A0 -] [ 8 A0 ] MOV
			1 # D0 SUB
		CS UNTIL
		\ remember never have anything on the stack 
		\ on the wrong side of the stack pointer.
		8 # S ADD
	NEXT
ANS 6.2.2300 TUCK

( x1 x2 -- x2 x1 x2 )

Copy the first (top) stack item below the second stack item. 


		    
	CODE TUCK ( 32b1 32b2 -- 32b2 32b1 32b2)
		S )+ D0 MOV
		S )+ D1 MOV
		D0 S -) MOV
		D1 S -) MOV
		D0 S -) MOV  
	NEXT
ANS 6.2.2440 WITHIN

( n1|u1 n2|u2 n3|u3 -- flag )

Perform a comparison of a test value n1|u1 with a lower limit n2|u2 and an upper limit n3|u3, returning true if either (n2|u2 < n3|u3 and (n2|u2 <= n1|u1 and n1|u1 < n3|u3)) or (n2|u2 > n3|u3 and (n2|u2 <= n1|u1 or n1|u1 < n3|u3)) is true, returning false otherwise. An ambiguous condition exists if n1|u1, n2|u2, and n3|u3 are not all the same type.

TRUE if lo <= n < hi 



	CODE WITHIN ( value lo hi - t)
		S )+ D0 MOV             \ hi
		S )+ D1 MOV             \ lo
		S )+ D2 MOV             \ n|u   
		FALSE # S -) MOV
		D1 D0 SUB               \ hi lo -   
		D1 D2 SUB               \ value lo -
		D0 D2 SUB               \ ( hi lo - ) ( value lo - ) -
		CS IF
			TRUE # S ) MOV
		THEN      
	NEXT
ANS 8.6.1.1040 D+

DOUBLE

( d1|ud1 d2|ud2 -- d3|ud3 )

Add d2|ud2 to d1|ud1, giving the sum d3|ud3. 



	CODE D+ ( lo1 hi1  lo2 hi2 -- lo3 hi3 )
		\ hi2 -> D0
		\ lo2 -> D1
		\ hi1 -> D2
		\ lo1 -> D3
		\ want 
		\ D2 hi3
		\ D3 lo3
		S ) \\ D3 D0 \\ MMOV
		8 # S ADD
		D1 D3 ADD
		D0 D2 ADDX
		\\ D3 D2 \\ S ) MMOV
	NEXT
ANS 8.6.1.1050 D-

DOUBLE

( d1|ud1 d2|ud2 -- d3|ud3 )

Subtract d2|ud2 from d1|ud1, giving the difference d3|ud3. 



	CODE D- ( lo1 hi1  lo2 hi2 -- lo3 hi3 )
		\ hi2 -> D0
		\ lo2 -> D1
		\ hi1 -> D2
		\ lo1 -> D3
		\ want 
		\ D2 hi3
		\ D3 lo3
		S ) \\ D3 D0 \\ MMOV
		8 # S ADD
		D1 D3 SUB
		D0 D2 SUBX
		\\ D3 D2 \\ S ) MMOV
	NEXT
ANS 8.6.1.1090 D2*

DOUBLE

( xd1 -- xd2 )

xd2 is the result of shifting xd1 one bit toward the most-significant bit, filling the vacated least-significant bit with zero. 


		 
	CODE D2* ( lo1 hi1 -- lo2 hi2 )
		S )+ D0 MOV \ hi
		S )+ D1 MOV \ lo
		0 # D2 MOV
		1 # D0 ASL
		1 # D1 ASL
		D2 D0 ADDX
		D1 S -) MOV
		D0 S -) MOV
	NEXT
ANS 8.6.1.1100 D2/

DOUBLE

( xd1 -- xd2 )

xd2 is the result of shifting xd1 one bit toward the least-significant bit, leaving the most-significant bit unchanged.
There is no ROXL instruction and I can see no better way 



	CODE D2/ ( lo1 hi1 -- lo2 hi2 )
		S )+ D0 MOV \ hi
		S )+ D1 MOV \ lo
		0 # D2 MOV
		1 # D1 LSR
		1 # D0 LSR
		D2 D2 ADDX
		1F # D3 MOV
		D3 D2 ASL
		D2 D1 OR
		D1 S -) MOV
		D0 S -) MOV
	NEXT
ANS 8.6.1.1160 DABS

DOUBLE

( d -- ud )

ud is the absolute value of d. 


		 
	CODE DABS ( lo1 hi1 -- lo2 hi2)
		S ) D0 MOV MI IF
			4 S) D1 MOV
			D1 NEG     \ low
			D0 NEGX    \ high
			D1 4 S) MOV
			D0 S ) MOV
		THEN
	NEXT
ANS 8.6.1.1230 DNEGATE

DOUBLE

( d1 -- d2 )

d2 is the negation of d1.



	CODE DNEGATE ( lo1 hi1 -- lo2 hi2 )
		S )+ D0 MOV
		S )+ D1 MOV
		D1 NEG		\ low
		D0 NEGX		\ high
		D1 S -) MOV
		D0 S -) MOV
	NEXT
ANS 8.6.2.0420 2ROT

DOUBLE EXT

( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )

Rotate the top three cell pairs on the stack bringing cell pair x1 x2 to the top of the stack. 



	CODE 2ROT  ( x5 x4 x3 x2 x1 x0 -- x3 x2 x1 x0 x5 x4 )
		S ) \\ D5 D0 \\ MMOV
		8 # S ADD
		\\ D3 D0 \\ S ) MMOV
		D5 S -) MOV
		D4 S -) MOV
	NEXT
ANS 8.6.2.1270 DU<

DOUBLE EXT

( ud1 ud2 -- flag )

flag is true if and only if ud1 is less than ud2. 



	-1 TRUE ??=
	CODE DU< ( lo1 hi1 lo2 h1 2 --flag)
		\ hi2 -> D0
		\ lo2 -> D1
		\ hi1 -> D2
		\ lo1 -> D3
		0 # D4 MOV \ for flag generation
		S ) \\ D3 D0 \ MMOV
		10 S) S LEA
		D1 D3 SUB
		D0 D2 SUBX
		D4 D4 SUBX \ generate flag
		D4 S -) MOV
	NEXT
ANS 17.6.1.0910 CMOVE

STRING

( c-addr1 c-addr2 u -- )

If u is greater than zero, copy u consecutive characters from the data space starting at c-addr1 to that starting at c-addr2, proceeding character-by-character from lower addresses to higher addresses.

If c-addr2 lies within the source region (i.e., when c-addr2 is not less than c-addr1 and c-addr2 is less than the quantity c-addr1 u CHARS +), memory propagation occurs.

Typical use: Assume a character string at address 100: ABCD. Then after
100 DUP CHAR+ 3 CMOVE
the string at address 100 is AAAA. 


	CODE CMOVE
		S )+ D1 MOV
		S )+ A0 MOV
		S )+ A1 MOV  
		1 # D1 SUB  CC IF
			BEGIN   
				A1 )+ A0 )+ B. MOV   
			1 # D1 SUB
			CS UNTIL 
		THEN  
	NEXT
ANS 17.6.1.0920 CMOVE>

STRING

( c-addr1 c-addr2 u -- )

If u is greater than zero, copy u consecutive characters from the data space starting at c-addr1 to that starting at c-addr2, proceeding character-by-character from higher addresses to lower addresses.

If c-addr1 lies within the destination region (i.e., when c-addr1 is greater than or equal to c-addr2 and c-addr2 is less than the quantity c-addr1 u CHARS +), memory propagation occurs.

Typical use: Assume a character string at address 100: ABCD. Then after
100 DUP CHAR+ SWAP 3 CMOVE>
the string at address 100 is DDDD. 


	CODE CMOVE>   
		S )+ D1 MOV
		S )+ A0 MOV
		S )+ A1 MOV 
		D1 A1 ADD   
		D1 A0 ADD   
		1 # D1 SUB  CC IF
			BEGIN   
				A1 -) A0 -) B. MOV   
			1 # D1 SUB
			CS UNTIL  
		THEN   
	NEXT
./version081/ansi_colon_words.html0100777000000000000000000003663607300314345016104 0ustar rootroot COLDFORTH KERNEL license
6.2.1485 FALSE

CORE EXT

( -- false )

Return a false flag.

 
    0 CONSTANT FALSE
6.2.2298 TRUE

CORE EXT

( -- true )

Return a true flag, a single-cell value with all bits set. 

 
    -1 CONSTANT TRUE
ANS 6.1.0100 */

( n1 n2 n3 -- n4 )

Multiply n1 by n2 producing the intermediate double-cell result d. Divide d by n3 giving the single-cell quotient n4. An ambiguous condition exists if n3 is zero or if the quotient n4 lies outside the range of a signed number. If d and n3 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R M* R> FM/MOD SWAP DROP or the phrase >R M* R> SM/REM SWAP DROP . 

   
	: */ ( n1 n2 n3 --n4)
		>R M* R> SM/REM NIP 
	;
6.1.0110 */MOD

star-slash-mod CORE

( n1 n2 n3 -- n4 n5 )

Multiply n1 by n2 producing the intermediate double-cell result d. Divide d by n3 producing the single-cell remainder n4 and the single-cell quotient n5. An ambiguous condition exists if n3 is zero, or if the quotient n5 lies outside the range of a single-cell signed integer. If d and n3 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R M* R> FM/MOD or the phrase >R M* R> SM/REM . 

 
	: */MOD ( n1 n2 n3 -- n4 n5 )
	>R M* R> SM/REM ;
ANS 6.1.0290 1+

CORE

( n1|u1 -- n2|u2 )

Add one (1) to n1|u1 giving the sum n2|u2. 

    
	: 1+ ( x1 - x2)   
		one + 
	;
ANS 6.1.0300 1-

CORE

( n1|u1 -- n2|u2 )

Subtract one (1) from n1|u1 giving the difference n2|u2. 

    
	: 1- ( x1 -- x2)
		one -
	;
ANS 6.1.0880 CELL+

CORE

( a-addr1 -- a-addr2 )

Add the size in address units of a cell to a-addr1, giving a-addr2. As with ALIGN and ALIGNED, the words CELL and CELL+ were added to aid in transportability across systems with different cell sizes. They are intended to be used in manipulating indexes and addresses in integral numbers of cell-widths. 

 
	Example: 
	 
	2VARIABLE DATA
	
	0 100 DATA 2!
	DATA @ . 100
	
	DATA CELL+ @ .  0
 
 
	: CELL+ ( a-addr1 -- a-addr2 )
		four +
	;

	: cell- ( a-addr -- a-addr2 )
		four -
	;
ANS 6.1.0310 2!

two-store CORE

( x1 x2 a-addr -- )

Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the next consecutive cell. It is equivalent to the sequence SWAP OVER ! CELL+ ! 

 
	: 2!  ( x1 x2 a-addr -- )
		SWAP OVER ! CELL+ !
	;
ANS 6.1.0320 2*

CORE

( x1 -- x2 )

x2 is the result of shifting x1 one bit toward the most-significant bit, filling the vacated least-significant bit with zero. 

 
	: 2* ( x1 -- x2 ) 
		one LSHIFT 
	;
ANS 6.1.0350 2@

two-fetch CORE

( a-addr -- x1 x2 )

Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and x1 at the next consecutive cell. It is equivalent to the sequence DUP CELL+ @ SWAP @ 

 
	: 2@ ( a-addr -- x1 x2 ) 
		DUP CELL+ @ SWAP @
	;
ANS 6.1.0706 ALIGNED

CORE

( addr -- a-addr )

a-addr is the first aligned address greater than or equal to addr. 

 
	: ALIGNED ( addr -- a-addr
		1+ -2 AND ;

	: 4aligned ( addr -- a-addr)
		3 + -4 AND ;

	\ line aligned, needed for fast DMA
	: 16aligned ( addr -- a-addr)
		0F + -10 AND ;
ANS 6.1.0770 BL

CORE

( -- char )

char is the character value for a space. Because space is used throughout Forth as the standard delimiter, this word is the only way a program has to find and use the system value of space. The value of a space character can not be obtained with CHAR, for instance. 

 
	20 CONSTANT BL
ANS 6.1.0890 CELLS

CORE

( n1 -- n2 )

n2 is the size in address units of n1 cells.
Example: 

 
	\ Allots space in the array NUMBERS for 100 cells of data. 
	CREATE NUMBERS 100 CELLS ALLOT 
 
 	
	: CELLS ( n1 -- n2)
		two LSHIFT
	;
ANS 6.1.0897 CHAR+

CORE

( c-addr1 -- c-addr2 )

Add the size in address units of a character to c-addr1, giving c-addr2. 

 
	: CHAR+  ( c-addr1 -- c-addr2 )
		1+
	; inline
ANS 6.1.0898 CHARS

CORE

( n1 -- n2 )

n2 is the size in address units of n1 characters. COLDFORTH As we plan to move to 16bit characters,this we try and use. 

 
	: CHARS ( n1 -- n2 ) ;  inline \ it actually adds nothing to the compiled code
ANS 6.1.0980 COUNT

CORE

( c-addr1 -- c-addr2 u )

Return the character string specification for the counted string stored at c-addr1. c-addr2 is the address of the first character after c-addr1. u is the contents of the character at c-addr1, which is the length in characters of the string at c-addr2. 

 

	zero
	DUP	CONSTANT	_#$_count	1+
	DUP CONSTANT    _#$_data
	DROP

	\ lenth of count field
	_#$_data _#$_count - CONSTANT #$count_length

	\ words to deal with string counts
	: $count@ C@ ;
	: $count! C! ;


	: COUNT ( c-addr1 -- c-addr2 u )
		DUP _#$_data + SWAP $count@
	;
ANS 6.1.1890 MOD

( n1 n2 -- n3 )

Divide n1 by n2, giving the single-cell remainder n3. An ambiguous condition exists if n2 is zero. If n1 and n2 differ in sign, the implementation-defined result returned will be the same as that returned by either the phrase >R S>D R> FM/MOD DROP or the phrase >R S>D R> SM/REM DROP. 

 
	.S .( MOD)
	: MOD ( n1 n2 -- n3 )
		>R S>D R> SM/REM DROP 
	;
ANS 8.6.1.1110 D<

DOUBLE

( d1 d2 -- flag )

flag is true if and only if d1 is less than d2. 

 
	.S .( D<)
	: D<            ( d1 d2 -- f )
		            ( l1 h1 l2 h2 -- f)
		\ Signed compare two double numbers.  If d1 < d2, return TRUE.
		2 PICK        \ l1 h1 l2 h2 h1 (--
		OVER =        \ l1 h1 l2 h2 h1 h2 (--
		IF
		    DU< 
		ELSE
			NIP       \ l1 h1 h2 (--
			ROT DROP  \ h1 h2 (--
			< 
		THEN
	;
	.S .( D< )
ANS 8.6.1.1075 D0<

DOUBLE

( d -- flag )

flag is true if and only if d is less than zero. 

 
	: D0<           ( d1 -- f1 )
	    zero zero D< 
	;
ANS 8.6.1.1080 D0=

DOUBLE

( xd -- flag )

flag is true if and only if xd is equal to zero. 

 
	: D0= ( xd -- flag )
	    OR 0=
	;
8.6.1.1120 D=

d-equals DOUBLE

( xd1 xd2 -- flag )

flag is true if and only if xd1 is bit-for-bit the same as xd2. 

 
	: D= ( d1 d2 --flag)
		D- OR 0=
	;
8.6.1.1140 D>S

d-to-s DOUBLE

( d -- n )

n is the equivalent of d. An ambiguous condition exists if d lies outside the range of a signed single-cell number. 

  
	: D>S
		DROP
	; inline
ANS 8.6.1.1210 DMAX

DOUBLE

( d1 d2 -- d3 )

d3 is the greater of d1 and d2. 

 
	: DMAX          ( d1 d2 -- d3 )
		4dup D< IF
			2SWAP
		THEN
		2DROP
	;
ANS 8.6.1.1220 DMIN

DOUBLE

( d1 d2 -- d3 )

d3 is the lesser of d1 and d2. 

 
	: DMIN          ( d1 d2 -- d3 )
		4dup 2SWAP D< IF
			2SWAP
		THEN 
		2DROP
	;

ANS extended precision maths

Robert Smith
tnegate

Tri negate. 

 
	: tnegate   ( t1lo t1mid t1hi -- t2lo t2mid t2hi )
		INVERT >R
		INVERT >R
		INVERT zero -1 -1 D+ S>D R> zero D+
		R> +
	;
ut*

Unsigned double by an unsigned integer to give a tri result. 

 
	: ut*   ( ulo uhi u -- utlo utmid uthi )
		SWAP >R dup>r
		UM* zero R> R> UM* D+
	;
mt*

Double by a integer to give a tri result. 

 
	.S .( mt*)
	: mt*   ( lo hi n -- tlo tmid thi )
		DUP 0< IF
			ABS OVER 0< IF
				>R DABS R> ut*
			ELSE
				ut* tnegate
			THEN
		ELSE
			OVER 0<
			IF
				>R DABS R> ut* tnegate
			ELSE
				ut*
			THEN
		THEN
	;
ut/

Divide a tri number by an integer. 

 
	.S .( ut/)
	: ut/   ( utlo utmid uthi n -- d1 )
		dup>r UM/MOD -rot R> UM/MOD
		NIP SWAP
	;
ANS 8.6.1.1820 M*/

( d1 n1 +n2 -- d2 )

Multiply d1 by n1 producing the triple-cell intermediate result t. Divide t by +n2 giving the double-cell quotient d2. An ambiguous condition exists if +n2 is zero or negative, or the quotient lies outside of the range of a double-precision signed integer. 

 
	.S .( M*/)
	: M*/  ( d1 n1 +n2 -- d2 )
		>R mt* DUP 0< IF
			tnegate R> ut/ DNEGATE
		ELSE
			R> ut/
		THEN
	;
ANS 17.6.1.0170 -TRAILING

( c-addr u1 -- c-addr u2 )

If u1 is greater than zero, u2 is equal to u1 less the number of spaces at the end of the character string specified by c-addr u1. If u1 is zero or the entire string consists of spaces, u2 is zero. 

 
	: -TRAILING ( c-addr u1 -- c-addr u2 )
		DUP IF
			>R DUP DUP R>     \ c-addr c_addr c-addr u1 (--
			CHARS +  [ 1 CHARS ]T LITERAL - \ c-addr c-addr end (--
			DO
				I char@ BL <> IF
					I OVER - [ 1 CHARS ]T LITERAL +
					UNLOOP
					EXIT
				THEN
			[ 1 CHARS NEGATE ]T LITERAL +LOOP  
			\ all blank
			zero
			EXIT
		THEN
	;
ANS 17.6.1.0245 /STRING

STRING

( c-addr1 u1 n -- c-addr2 u2 )

Adjust the character string at c-addr1 by n characters. The resulting character string, specified by c-addr2 u2, begins at c-addr1 plus n characters and is u1 minus n characters long.

/STRING is used to remove or add characters relative to the left end of the character string. Positive values of n will exclude characters from the string while negative values of n will include characters to the left of the string. /STRING is a natural factor of WORD and commonly available. 

 
	: /STRING ( c-addr len n -- c-addr2 len2 )
		OVER MIN	\ c-addr len min (--
		TUCK        \ c-addr min len min (--
		-           \ c-addr min len2 (--
		-rot        \ len2 c-addr min (--
		+			\ len2 c-addr2 (--
		SWAP        \ c-addr2 len2 (--
	;
ANS 17.6.1.0780 BLANK

STRING

( c-addr u -- )

If u is greater than zero, store the character value for space in u consecutive character positions beginning at c-addr. 

 
	.S .( BLANK) 
	: BLANK ( c-addr u --)
		BL FILL ;
ANS 17.6.1.0935 COMPARE

STRING

( c-addr1 u1 c-addr2 u2 -- n )

Compare the string specified by c-addr1 u1 to the string specified by c-addr2 u2. The strings are compared, beginning at the given addresses, character by character, up to the length of the shorter string or until a difference is found. If the two strings are identical, n is zero. If the two strings are identical up to the length of the shorter string, n is minus-one (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not identical up to the length of the shorter string, n is minus-one (-1) if the first non-matching character in the string specified by c-addr1 u1 has a lesser numeric value than the corresponding character in the string specified by c-addr2 u2 and one (1) otherwise. 

 
	.S .( _#less)	
	\ Describe the result, sorry I hate magic numbers.
	-1  CONSTANT _#less
	0   CONSTANT _#same
	1   CONSTANT _#greater
	\
	: COMPARE ( addr1 u1 addr2 u2 --tri)
		ROT                  \ addr1 addr2 u2 u1 (--
		\ If the strings are equal up to the shortest the result
		\ depends on the length. The strings are treated as if the 
		\ missing characters are less than zero.
		2DUP > IF            \ addr1 addr2 u2 u1 (--
			_#less
		ELSE
			2DUP < IF
				_#greater
			ELSE
				_#same
			THEN
		THEN
							\ addr1 addr2 u2 u1 value (--
		>R
		MIN zero ?DO
			DUP char@       \ addr1 addr2 char2 (--
			jump char@      \ addr1 addr2 char2 char1 (--
			2DUP         \ addr1 addr2 char2 char1 char2 char1(--
			> IF
				4drop
				_#greater
				UNLOOP
				r>drop
				EXIT
			THEN
			< IF
				2DROP
				_#less 
				UNLOOP
				r>drop
				EXIT
			THEN
			CHAR+ SWAP CHAR+ SWAP \ addr1+1 addr2+1 (--
		[ 1 CHARS ]T LITERAL +LOOP
		2DROP
		\ equal up to the shortest, result depends on length
		R>
	;
17.6.1.2191 SEARCH

STRING

( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )

Search the string specified by c-addr1 u1 for the string specified by c-addr2 u2. If flag is true, a match was found at c-addr3 with u3 characters remaining. If flag is false there was no match and c-addr3 is c-addr1 and u3 is u1. 

 
	: _byte_data= ( c-addr c-addr2 u2 -- flag)
		zero DO
			OVER C@ OVER C@ <> IF
				2DROP UNLOOP FALSE EXIT
			THEN
			1+ SWAP 1+
		LOOP
		2DROP
		TRUE
	;
	

	: SEARCH { ( c-addr1 u1 ) variable c-addr2 variable u2 -- ( c-addr3 u3 flag ) }{ 
	
	}
	u2 @ 0= IF 
		TRUE
		EXIT
	THEN
	\ once around for each character position
	2DUP              \ c-addr1 u1 c-addr1 u1(--
	BEGIN
		\ if search string is greater in length than number of characters left 
		\ then failure.
		u2 @ OVER > IF  
			2DROP
			FALSE
			EXIT
		THEN
		OVER
		c-addr2 @ u2 @   \ c-addr1 u1 c-addr1 u1 c-addr1 c-addr2 u2(--  
		_byte_data= IF
			2SWAP 2DROP
			TRUE
			EXIT
		THEN
		SWAP 1+
		SWAP 1-
	AGAIN
	;
./version081/ass.html0100777000000000000000000042362407300314345013325 0ustar rootroot COLDFORTH KERNEL license
Bugs to be fixed
bugs fixed
Version 2.3
	5407 support added; the 68k instructions are ruturning.
Version 2.2
	32 bit branch BRA, coldfire doesn't support
	long word immediate value MUL
Verion 2.1
	Recoded in forth. 
Version 2.0
	Instruction support limited to coldfire, the 68k has gone.

##### A forward reference, not too sure if still needed 

 
| CREATE 'init_assembler 0 t,
    
| : init_assembler ( --)
    'init_assembler @execute 
;

When in assembler you lose access to the forth OR and AND, these two words are there to give them back to you. 

 

| : forth_or OR ;
| : forth_and AND ;

HOST

Used to install a exception in the interrupt tables. To create an exception word use interrupt: 

 
	: EXCEPTION ( a n) 4 *  _interrupt_vectors  + ! ;

add assembler to the target : search order, all : words are now added to the target assembler vocabulary. 

 
	target_also
	ASSEMBLER
	target_definitions

add assembler to the host : search order, all host : words are now added to the host assembler vocabulary. 

 
	assembler DEFINITIONS
Assemble version stuff
 
	: .history ( --)
		CR
		." Assembler history" CR
		."    2.0 COLDFIRE version" CR
		."    2.1 All assembler removed ready for port to GFORTH" CR 
		."    2.2 Some bug fixes" CR 
		."    2.3 5407 instructions added" CR
	;

	CREATE $ASSEMBLER_VERSION ( --)	
		," 2.3"

	#230 CONSTANT ASSEMBLER_VERSION

	: .version $ASSEMBLER_VERSION $type ;

Vectored for cross compile. When the system want to cross compile the assembler has to store the results in the target dictionary. Instead of reloading the assembler these vectored words are altered. 

 
	| : ahere 'ahere @execute ;
	| : aw!   ( 16b addr --) 'aw!   @execute ;
	| : aw@   ( addr -- 16b) 'aw@   @execute ;
	| : agap  ( n --)        'agap  @execute ;

Following are defined from vectored words. 

 
	| : a!    ( 32b addr--)  >R  DUP >w< I aw!  R> 2+ aw! ;

	| : a@    ( addr -- 32b) DUP aw@ 10000 * SWAP 2+ aw@ + ;

	| : AMOVE ( s d n --)
		OVER + SWAP ?DO 
			DUP W@  I  aw!  2+ 2 
		+LOOP 
		DROP 
	;

The assembler makes heavy use of vector tables. These words supply support for the building of these tables. Used at xcompile time and lost. 

 
	forth  : init_vectors ( word number --)
	  	forth  DUP HOST tw,
	  	forth  zero DO 
	  		DUP HOST t, forth 
	  	LOOP 
	  	DROP 
	;

	forth  : add_vector ( addr num table --)
	  	forth DUP HOST TW@ forth jump > not
	  	ABORT" Vector number out of range"
	  	SWAP 4* + 2+ HOST t! 
	;

	\ mive back to assembler ( in host) after the above forth's.
	assembler

Hard to credit it but for the 68040 the value of this was 22. The coldfire instruction set is such that it is now 6.

##### change to 6 
 
	| 22 CONSTANT #max_instruction


( Sytem errors)
( None of these should be seen)
( 01  test_vectors.  Unused table entry called )
(     [ test_set test_entry ] )
( 02  Effective address compile was called with )
(     wrong ef code in #_code . )
( 03  Data size code supplied by relative words wrong, )
(     this one you should never get, a trivial test. )
( 04  The compile code vector failed. )
( 05  #vectors. Non entry called. )
( 06  effective address sets, no entry. )
( 07  The code supplied to makebitfield was wrong.)
( 08  #_displacment was non zero)
( 09  #_scale was non zero )
( 0A  mode>regoffset entry not set)


( test_error)
( n is the number of stack its to print)

| : (system_error) ( ? n error_code --)
	SWAP zero ?DO 
		.h
	LOOP
	.h  TRUE
	ABORT" ASSEMBLER SYSTEM_ERROR PLEASE RECORD NUMBERS" 
;

( %cpu Assembler )  
HEX
0F  EQU #all_68000
F0  EQU #all_coldfire

1   CONSTANT #68000
2   CONSTANT #68040
4   CONSTANT #CPU32
10  CONSTANT #5300
20  CONSTANT #5400

: !CPU  ( n --) %cpu ! ;

( special register codes)  
HEX

1 EQU #PC
2 EQU #SR
3 EQU #CCR
4 EQU #ACC
5 EQU #MASK
6 EQU #MACSR
( USP is encoded as a control reg, but encoded An USP MOV)
| 800 EQU #USP
( CPUs that support long branches)
| #CPU32 #68040 + #5400 + CONSTANT #long_branch

( CPUs that support long PC rel)
( e.g. [ n32 PC ]              )
| #CPU32 #68040 + CONSTANT #long_PC

(  %ef_table contains the effective address data)
| 0   DUP  CONSTANT #_displacement      4 + ( The constant)
	  DUP  CONSTANT #_scale             4 + ( ind scale factor)
( the reg code has to be 16 bits for MOVC)
	DUP CONSTANT #_reg               	2 + ( First reg)
	DUP CONSTANT #_index             	2 + ( Second reg)
	DUP CONSTANT #_size              	1 + ( ind size)
|	DUP CONSTANT #_mode              	1 + ( ] ]+ -] # \\)
    DUP CONSTANT #_address_data
|   DUP CONSTANT #_code          	    1 + ( ef_code)
|   DUP CONSTANT #_flags				1 +
		CONSTANT    #ef_entry_length
| 04    CONSTANT    #ef_entryASL


( The ef_code is determined when the mnemonic is compiled)
(  %ef_table contains the effective address data)  HEX
( We need three sets of entries per field, we make it four)
( so ASL can be used.)

| 06 CONSTANT     #ef_fieldASL
| 40 CONSTANT     #ef_field_length
| 05 CONSTANT     #num_fields  ( source and destination)
						  ( can be source, dest, bit_field_spec)

3 CONSTANT #indirection ( maximum level of indirection)


\ We define the data area using a ubuffer so multiple tasks can use the assembler

\ determine the data area offsets
zero 
DUP CONSTANT _#ind_stack  #indirection 4* +
DUP CONSTANT _#indirection CELL+
DUP CONSTANT _#field       CELL+
DUP CONSTANT _#ef_table   #ef_field_length
						  #num_fields  *  +
DUP CONSTANT _#ximage     #max_instruction +
DUP CONSTANT _#xh         CELL+
    CONSTANT _#assembler_data_size

_#assembler_data_size ubuffer _assembler_data_area
( data area for indirection) 
DECIMAL
\ when you entry a [ ] pair the address of the data stack
\ is saved, this is used to determine how many values
\ have been pushed on the stack.
: %ind_stack    _assembler_data_area _#ind_stack + ;
\ number of [] pairs found, coldfire is limited to one,
\ this assembler once supported the 68040 which requireds two
: %indirection  _assembler_data_area _#indirection + ;
\ Number of fields found the MAC increases the possible number
\ 4
: %field        _assembler_data_area _#field + ;
: %ef_table     _assembler_data_area _#ef_table + ;
\ we build the code here and then copy to dictionary
: %ximage       _assembler_data_area _#ximage + ;
\ points to location within %ximage
: %xh           _assembler_data_area _#xh + ;


( image area support) 
HEX


	: XHERE 
		%xh @
	;



	: XW,  ( 16b --) 
		%xh @ W!
		2 %xh +!
	;


	: X, ( 32b --)
		%xh @ !
		4 %xh +!
	;


	: @opcode ( --16b)
		%ximage W@
	;


	: !opcode ( 16b--)
		%ximage W!
	;





| 0 CONSTANT #source
| 1 CONSTANT #dest
| 2 CONSTANT #Freg
| 3 CONSTANT #Wreg


( #_reg and #_index description Assembler ) 
( Only #_reg should see the fancy modes)
binary
| 1000000000000000    CONSTANT    #control_reg  ( reg num 12 bits)
| 0100000000000000    CONSTANT    #cpu_reg      ( reg num 4 bits)
| 0010000000000000    CONSTANT    #special_reg
| 0001000000000000    CONSTANT    #flag         ( cond 4 bits)
| 0000100000000000    CONSTANT    #cache        ( 2 bits)
| 1111100000000000    CONSTANT    #cache_test
( #reg useage)
| 0000000000000111    CONSTANT    #reg_number
| 0000000000001000    CONSTANT    #reg_set      ( 0 = data 1 = add)
| 0000000000001000    CONSTANT    #addr
| 0000000000000000    CONSTANT    #data
| 0000000000001111    CONSTANT   #set®
#cpu_reg              CONSTANT    #data_reg
#cpu_reg #reg_set +   CONSTANT    #addr_reg

DECIMAL

( size codes used in assembler)
| 1 CONSTANT #byte
| 2 CONSTANT #word
| 3 CONSTANT #long
( #mode description)

\ no shift is default
01 CONSTANT #flags<<
03 CONSTANT #flags>>
\ no mask is default
04 CONSTANT #flags&
08 CONSTANT #flagsU.

binary

| 00000001 CONSTANT #_]+
| 00000010 CONSTANT #_-]
| 00000100 CONSTANT #_#
| 00001000 CONSTANT #_]
| 00010000 CONSTANT #_}
| 00100000 CONSTANT #_\\

HEX
( The test routines need to know the ef_table offsets)
( The order of entries determines order of test.)
( We test in quickest order )
CREATE ef_offsets
	0      tw,                                   zero
	#_mode          tw,                          1+
	#_reg           tw,                          1+
	#ef_entry_length   #_mode        + tw,       1+
	#ef_entry_length   #_reg         + tw,       1+
	#ef_entry_length  2*  #_mode        + tw,    1+
	#ef_entry_length  2*  #_reg         + tw,    1+
	#_displacement   tw,                         1+
	#_index         tw,                          1+
	#_size          tw,                          1+
	#_scale         tw,                          1+
	#ef_entry_length   #_displacement + tw,      1+
	#ef_entry_length   #_index       + tw,       1+
	#ef_entry_length   #_size        + tw,       1+
	#ef_entry_length   #_scale       + tw,       1+
	#ef_entry_length  2*  #_displacement + tw,   1+
	#ef_entry_length  2*  #_index       + tw,    1+
	#ef_entry_length  2*  #_size        + tw,    1+
	#ef_entry_length  2*  #_scale       + tw,    1+
	0 tw,                                        1+   \ cpu type
\ count of entries
ef_offsets TW!


HEX
( This table contains a byte for each entry in the %ef_table)
( The byte indicates the test to be done on the entry)
( the value is a test vector number by 4.)
( Note that the data arrangment make it a simple matter to )
( vector to the test routine.)

040 EQU #max_test_codes

( The #vectors are used in the INSTRUCTION tables)
( They are used to limit the range of immediate values)

010 EQU #max_#vectors

( The ef_test_table starts with an entry count and then )
( has entries arranged)
14  CONSTANT    #tests  ( Number of tests to be performed)


0   DUP EQU    #ef_test_tests  #tests +
	DUP CONSTANT    #ef_test_cpu    1+  ( cpus that support)

		CONSTANT    #ef_test_entry_length


	: notest ( teseted_entry --flag)
		DROP TRUE
	;

	: 1zero (  tested_entry -- flag)
		C@ 0= 
	;


	: 2zero (  tested_entry -- flag)
		W@ 0= 
	;


	: 4zero (  tested_entry -- flag)
		@ 0= 
	;
 

	: data_reg ( tested_entry --flag)
		W@ 
		[ #reg_number -1 XOR ]T LITERAL AND	#data_reg =
	;


	: addr_reg ( tested_entry --flag)
		W@ 
		[ #reg_number -1 XOR ]T LITERAL AND	#addr_reg =		 
	;

	: ccr ( tested_entry --flag)
		W@ 
		[ #special_reg #CCR + ]T LITERAL =		 
	;

	: acc ( tested_entry --flag)
		W@ 
		[ #special_reg #ACC + ]T LITERAL =		 
	;

	: mask ( tested_entry --flag)
		W@ 
		[ #special_reg #MASK + ]T LITERAL =		 
	;

	: macsr ( tested_entry --flag)
		W@ 
		[ #special_reg #MACSR + ]T LITERAL =		 
	;

	: pc_reg ( tested_entry --flag)
		W@ 
		[ #special_reg #PC + ]T LITERAL =		 
	;


	: sr ( tested_entry --flag)
		W@ 
		[ #special_reg #SR + ]T LITERAL =		 
	;


	\ #### not needed
	: usp ( tested_entry --flag)
		W@ 
		[ #special_reg #USP + ]T LITERAL =		 
	;


	: caches ( tested_entry --flag)
		W@
		#cache_test AND 
		[ #cache ]T LITERAL =		 
	;


	: cond ( tested_entry --flag)
		W@ #flag AND 0<>		 
	;
 

	: rc ( tested_entry --flag)
		W@ #control_reg AND 0<>		 
	;



	: n16 ( tested_entry --flag)
		@ -8000 8000 WITHIN
	;


	: n8 ( tested_entry --flag)
		@ -80 80 WITHIN
	;


	: 0>31 ( tested_entry --flag)
		@ [ 1F -1 XOR ]T LITERAL AND 0=
	;


	: mode\\ ( tested_entry --flag)
		C@ #_\\  =
	;


	: mode} ( tested_entry --flag)
		C@ #_} =
	;

	: mode] ( tested_entry --flag)
		C@ #_] =
	;


	: mode]+ ( tested_entry --flag)
		C@ #_]+ =
	;


	: mode-] ( tested_entry --flag)
		C@ #_-] =
	;


	: mode# ( tested_entry --flag)
		C@ #_# =
	;
 
 
\	: W.L. ( tested_entry --flag)
\		C@
\		DUP #long = 
\		OVER #word = OR
\		\ nothing is the same as long
\		SWAP 0= OR
\	;

	: .long ( tested_entry --flag)
		C@
		DUP #long = 
		\ nothing is the same as long
		SWAP 0= OR
	;

	: 1scale ( tested_entry --flag)
		@
		DUP 0= 
		SWAP 1 = OR
	;

	: allscale ( tested_entry --flag)
		@
		DUP 0= 
		OVER 1 = OR
		OVER 2 = OR
		OVER 4 = OR
		SWAP 8 = OR
	;



	: reg  ( tested_entry --flag)
		W@
		[ #reg_number -1 XOR ]T LITERAL AND
		[ #reg_number -1 XOR ]T LITERAL AND
		#cpu_reg =
	;


	: test_cpu ( test_entry tested_entry -- test_entry flag)
		DROP DUP #ef_test_cpu + C@
		%cpu @ AND 0= ABORT" Addressing mode not supported by selected CPU"
		TRUE 
	;



	: test_error ( test_table_entry tested_entry --)
		ABORT" System error test vector missing
	;


( sort names for the test table)
zero
DUP  EQU =notest          4+
DUP  EQU =1zero           4+
DUP  EQU =2zero           4+
DUP  EQU =4zero           4+
DUP  EQU =data_reg        4+
DUP  EQU =addr_reg        4+
DUP  EQU =pc_reg          4+
\ DUP  EQU =z+pc_reg        4+
DUP  EQU =reg             4+
\ DUP  EQU =W.L.            4+
DUP  EQU =.long           4+
DUP  EQU =allscale        4+
DUP  EQU =1scale          4+
DUP  EQU =]               4+
DUP  EQU =]+              4+
DUP  EQU =-]              4+
DUP  EQU =#               4+
DUP  EQU =cpu             4+
DUP  EQU =CCR             4+
DUP  EQU =ACC             4+
DUP  EQU =MASK            4+
DUP  EQU =MACSR           4+
DUP  EQU =SR              4+
DUP  EQU =USP             4+
DUP  EQU =Rc              4+
DUP  EQU =\\              4+
DUP  EQU =caches          4+
DUP  EQU =cond            4+
DUP  EQU =}               4+
DUP  EQU =n16             4+
DUP  EQU =n8              4+
DUP  EQU =0>31            4+

#max_test_codes 4* ??< 


\ xt table
| CREATE test_vectors
	\ code word
	' test_error  #max_test_codes init_vectors

' notest           =notest    	4/ test_vectors add_vector
' 1zero     		=1zero     	4/ test_vectors add_vector
' data_reg  		=data_reg  	4/ test_vectors add_vector
' addr_reg  		=addr_reg  	4/ test_vectors add_vector
' pc_reg    		=pc_reg    	4/ test_vectors add_vector
\ ' z+pc_reg  		=z+pc_reg  	4/ test_vectors add_vector
' reg       		=reg       	4/ test_vectors add_vector
' 2zero     		=2zero     	4/ test_vectors add_vector
' mode]     		=]         	4/ test_vectors add_vector
' mode]+    		=]+       	4/ test_vectors add_vector
' mode-]    		=-]       	4/ test_vectors add_vector
' mode#     		=#        	4/ test_vectors add_vector
\ ' W.L.             	=W.L.     	4/ test_vectors add_vector
' .long             =.long      4/ test_vectors add_vector
' allscale         	=allscale 	4/ test_vectors add_vector
' 1scale           	=1scale   	4/ test_vectors add_vector
' 4zero            	=4zero    	4/ test_vectors add_vector
' test_cpu         	=cpu      	4/ test_vectors add_vector
' ccr              	=CCR      	4/ test_vectors add_vector
' acc              	=ACC      	4/ test_vectors add_vector
' mask              =MASK      	4/ test_vectors add_vector
' macsr             =MACSR      4/ test_vectors add_vector
' sr               	=SR       	4/ test_vectors add_vector
' usp              	=USP      	4/ test_vectors add_vector
' rc               	=Rc       	4/ test_vectors add_vector
' mode\\           	=\\       	4/ test_vectors add_vector
' caches           	=caches   	4/ test_vectors add_vector
' cond             	=cond     	4/ test_vectors add_vector
' mode}            	=}        	4/ test_vectors add_vector
' n16              	=n16      	4/ test_vectors add_vector
' n8               	=n8      	4/ test_vectors add_vector
' 0>31             	=0>31     	4/ test_vectors add_vector

( address codes)

zero
| 	DUP CONSTANT #.null               1+
	DUP EQU #.Dn                       1+
	DUP EQU #.An                       1+
	DUP EQU #.[An]                     1+
	DUP EQU #.[An]+                    1+
	DUP EQU #.[An-]                    1+
	DUP EQU #.[n16.An]                 1+
	DUP EQU #.[n16]                    1+
|	DUP CONSTANT #.[n32]               1+
| 	DUP CONSTANT #.#                   1+
	DUP EQU #.[n8.An.In.1]             1+
	DUP EQU #.[n8.An.In.sc]            1+
	DUP EQU #.[n.PC]                   1+
	DUP EQU #.[n.PC.In.1]              1+
	DUP EQU #.[n.PC.In.sc]             1+
	DUP EQU #.CCR                      1+
	DUP EQU #.ACC                      1+
	DUP EQU #.MASK                     1+
	DUP EQU #.MACSR                    1+
	DUP EQU #.SR                       1+
	DUP EQU #.USP                      1+
	DUP EQU #.Rc                       1+
	DUP EQU #.Rlist                    1+
	DUP EQU #.caches                   1+
	DUP EQU #.cond 1+
		EQU #.num_test_sets



\ test entry order
\
\   mode                        reg
\   [mode                       [reg
\   [[mode                      [[reg
\   displacement                index
\   size                        scale
\   [displacement               [index
\   [size                       [scale
\   [[displacement              [[index
\   [[size                      [[scale
\   general                     cpu

\  See ef_offsets
CREATE ef_test_table
#.num_test_sets tw,          zero
	( Null)
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=notest     tc,  =4zero      tc, ( we allow size code)
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,
	#all_68000 #all_coldfire +        tc,
DUP #.null ??=


( ef_test_table)  1+
	( Dn)
	=1zero      tc,  =data_reg   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.Dn ??=


( ef_test_table)  1+
	( An)
	=1zero      tc,  =addr_reg   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.An ??=


( ef_test_table) 1+
	( [ An ]  accept [ An W. ] has no meaning )
	=1zero      tc,  =2zero      tc,
	=]          tc,  =addr_reg   tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=.long      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[An] ??=


( ef_test_table) 1+
	( [ An ]+ )
	=1zero      tc,  =2zero      tc,
	=]+         tc,  =addr_reg   tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[An]+ ??=


( ef_test_table) 1+
	( [ An -] )
	=1zero      tc,  =2zero      tc,
	=-]         tc,  =addr_reg   tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[An-] ??=


( ef_test_table) 1+
	( [ n16 An ] )
	=1zero      tc,  =2zero      tc,
	=]          tc,  =addr_reg   tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=n16        tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[n16.An] ??=


( ef_test_table) 1+
	( [ n16 ]  note [ ] <=> [ 0 ]  )
	=1zero      tc,  =2zero      tc,
	=]          tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=n16        tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[n16] ??=


( ef_test_table) 1+
	( [ 32b ]  )
	=1zero      tc,  =2zero      tc,
	=]          tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[n32] ??=


( ef_test_table) 1+
	(  #  )
	=#          tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=notest     tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.# ??=


( ef_test_table) 1+
	(  [ n8 An In 1 ]  will accept [ An In ]  )
	=1zero      tc,  =2zero      tc,
	=]          tc,  =addr_reg   tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=n8         tc,  =reg        tc,
	=.long      tc,  =1scale     tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[n8.An.In.1] ??=


( ef_test_table) 1+
	(  [ n8 An In scale ]  will accept [ An In scale ]  )
	=1zero      tc,  =2zero      tc,
	=]          tc,  =addr_reg   tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=n8         tc,  =reg        tc,
	=.long       tc,  =allscale   tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =cpu        tc,

	#CPU32 #5300 + #5400 + #68040 + tc,
DUP #.[n8.An.In.sc] ??=


( ef_test_table) 1+
	(  [ n PC ]  at this stage n is unknown as extension )
	(  address not known.)
	=1zero      tc,  =2zero      tc,
	=]          tc,  =pc_reg     tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[n.PC] ??=


( ef_test_table) 1+
	(  [ n PC In 1 ]  will accept [ PC In ]  )
 ( at this state n is unknown as extension address unknown)
	=1zero      tc,  =2zero      tc,
	=]          tc,  =pc_reg     tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =reg        tc,
	=.long      tc,  =1scale     tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.[n.PC.In.1] ??=


( ef_test_table) 1+
	(  [ n PC In scale ]  will accept [ PC In scale ]  )
	=1zero      tc,  =2zero      tc,
	=]          tc,  =pc_reg     tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =reg        tc,
	=.long      tc,  =allscale   tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =cpu        tc,

	#CPU32 #5300 + #5400 + #68040 + tc,
DUP #.[n.PC.In.sc] ??=


( ef_test_table)  1+
	( CCR)
	=1zero      tc,  =CCR   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
	DUP #.CCR ??=

( ef_test_table)  1+
	( ACC)
	=1zero      tc,  =ACC   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
	DUP #.ACC ??=

( ef_test_table)  1+
	( MASK)
	=1zero      tc,  =MASK   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
	DUP #.MASK ??=

( ef_test_table)  1+
	( MACSR)
	=1zero      tc,  =MACSR   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
	DUP #.MACSR ??=


( ef_test_table)  1+
	( SR)
	=1zero      tc,  =SR   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.SR ??=


( ef_test_table)  1+
	( USP)
	=1zero      tc,  =USP   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.USP ??=


( ef_test_table)  1+
	( Rc)
	=1zero      tc,  =Rc   tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#68040 #CPU32 + #5300 + #5400 +     tc,
DUP #.Rc ??=


( ef_test_table)  1+
	(  Rlist )
	=\\         tc,  =notest     tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=notest     tc,  =notest     tc,
	=notest     tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +        tc,
DUP #.Rlist ??=

( ef_test_table)  1+
	( caches )
	=1zero      tc,  =caches     tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =cpu        tc,

	#all_coldfire     tc,

	DUP #.caches ??=

( ef_test_table)  1+
	( cond )
	=1zero      tc,  =cond       tc,
	=1zero      tc,  =2zero      tc,
	=1zero      tc,  =2zero      tc,
	=4zero      tc,  =2zero      tc,
	=notest     tc,  =4zero      tc,
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc, 
	=4zero      tc,  =2zero      tc,
	=1zero      tc,  =4zero      tc,
	=notest     tc,  =notest     tc,

	#all_68000 #all_coldfire +                        tc,
DUP #.cond  ??=

1+ #.num_test_sets ??=


	: entry_test ( ef_test_table entry -- ef_test_table entry flag )
		#tests zero DO
			\ ef_test_table  entry
			2DUP  \ test_table entry test_table entry(-- 
			I 2*  [ ef_offsets 2+ ]T LITERAL + W@ + \ test_table entry test_table table_entry (--
			\ The vector table is long enough to support all possible codes.
			\ The unused codes will generate errors.
			OVER I + C@ [ test_vectors 2+ ]T LITERAL + 
			\ .S ." test_entry entry test_table vector(--"
			@execute \ test_table entry test_table flag(--
			NIP                   \ test_table entry flag(--
			0= IF   \ this entry failed
				FALSE
				2r>drop
				EXIT
			THEN
		LOOP
		TRUE
	;
	\ get here and all is ok


	| : can't_do ( --)
		TRUE ABORT" Instruction modifiers wrong."  ;

	: field_address ( n --address)
		#ef_fieldASL LSHIFT
		%ef_table + 
	;
	

	: ef_code ( entry --)
		ef_test_table 2+   \ entry test_table
		SWAP               \ test_table entry (--
		ef_test_table W@ zero DO
			\ test_table entry(--
			entry_test IF ( this is it)
				I SWAP #_code + C! 
				DROP
				2r>drop
				EXIT
			THEN
			SWAP
			#ef_test_entry_length +
			SWAP 
		LOOP
\		$100 DUMP
		TRUE ABORT" Instruction modifiers wrong."  
	;

 
| CREATE code>regoffset
#.num_test_sets ALLOT
0                    #.Rc       code>regoffset + TC!
0                    #.Dn       code>regoffset + TC!
0                    #.An       code>regoffset + TC!
0                    #.caches   code>regoffset + TC!
0                    #.cond     code>regoffset + TC!
#ef_entry_length     #.[An-]    code>regoffset + TC!
#ef_entry_length     #.[An]+    code>regoffset + TC!
#ef_entry_length     #.[An]     code>regoffset + TC!
#ef_entry_length     #.[n16.An] code>regoffset + TC!


( register use words)
\ The order things are encounted has to be retained.
\ n r has to be stored     displacment reg
\ r n has to be stored     scale       reg
\ n   has to be stored     displacment

\ The rules are, r stores into displacement
\                ] stores into scale if reg found.

| : wrong_cpu ( --) TRUE ABORT" Register not supported by selected CPU." ;
| : to_many]    	TRUE ABORT" Too many closing brackets." ;
| : stack_under 	TRUE ABORT" Stack underflow." ;
| : stack_over  	TRUE ABORT" To many stack items." ;
| : mode_used   	TRUE ABORT" Mixed addressing modes." ;
| : incorrect   	TRUE ABORT" Numbers and registers mixed up." ;
| : to_many_fields	TRUE ABORT" To many fields." ;
| : reg_list_error	TRUE ABORT" Register list structure error." ;
| : to_many{ 		TRUE ABORT" To many opening brackets." ;
| : to_many[ 		TRUE ABORT" To many opening brackets." ;

zero 
DUP CONSTANT _#register_code 2+
DUP CONSTANT _#register_cpu  2+
DROP

forth : REGISTER  
	HOST (CREATE) tw, tw, 
	DOES>  ( ?? pfa --)
		DUP _#register_cpu + W@ %cpu @ AND not ABORT" Wrong cpu" \ ?? pfa(--
		%indirection @ #ef_entryASL LSHIFT   \ ?? pfa indirection (--
		%field @ #num_fields < not ABORT" To many fields"  \ ?? pfa indirections(--
		%field @ #ef_fieldASL LSHIFT   \ ?? pfa indirection field (--
		+ %ef_table + \ pfa addr(--
		( If register is part of a list treat differently)
		( This deals with MMOV )
		DUP #_mode + C@ #_\\ = IF  \ pfa addr(--
			DUP #_reg + W@ not IF  \ pfa addr(--( first of pair)
				SWAP _#register_code + W@ SWAP #_reg + W!
				EXIT
			THEN
			DUP #_index + W@ not IF
				SWAP _#register_code + W@ SWAP #_index + W!
				EXIT
			THEN
			TRUE ABORT" Register list structure wrong"
		THEN
		\ ?? pfa addr(--
		\ If we have [ ] we can keep track of stack items as [ stores the stack pointer.
		\ If a value is put on a the stack before the register it is an offset
		\ If put on the stack after the register it is a scale.
		%indirection @ IF
			%indirection @ 4* 
			%ind_stack + @
			\ horrible code assumes a descending stack
			@s 3 CELLS +    \ allow for the stack values that are above ??
			-               \ ?? pfa addr items*cells(--
			DUP 0< ABORT" STACK underflow"
			DUP cell >  ABORT" STACK overflow"
			\ if the utems*cells = 4 then ?? becomes value
			cell = IF \ value pfa addr(--
				\ If number before register a displacment
				\ if after the register a scale
				DUP #_reg + W@ not IF ( a displacment)
					\ value pfa addr(--
					DUP #_displacement + @ ABORT" System displacment error"
					ROT OVER #_displacement + !
					\ pfa addr(--
				ELSE
					DUP #_scale + @ ABORT" System scale error"
					ROT OVER #_scale + !
					\ pfa addr(--
				THEN
			THEN
		THEN
		\ pfa addr(--
		#_reg OVER + W@ not IF
			SWAP _#register_code + W@ SWAP #_reg + W! \ (--
			\ This is saying that if there is no [ then a register child
			\ increments field. If there is a [ then things get more complex.
			\ If fact it is the ] that increments the field
			%indirection @ not IF
				1 %field +!
			THEN
			EXIT
		THEN
		\ pfa addr(--
		#_index OVER + W@ not IF
			SWAP _#register_code + W@ SWAP #_index + W! \ (--
			EXIT
		THEN
		TRUE ABORT" Can't use register"
	;

			
( ] )
forth : TERMINATOR
	HOST
	(CREATE) tw, ( mode) 
	DOES> \ ?? pfa
		%indirection @ not ABORT" Too many ]"
		%indirection @ #ef_entryASL LSHIFT   \ ?? pfa indirection (--
		%field @ #num_fields < not ABORT" To many fields"  \ ?? pfa indirections(--
		%field @ #ef_fieldASL LSHIFT   \ ?? pfa indirection field (--
		+ %ef_table + \ ?? pfa addr(--

		%indirection @ 4* 
		%ind_stack + @
		\ horrible code assumes a descending stack
		@s 3 CELLS +    \ allow for the stack values that are above ??
		-               \ ?? pfa addr items*cells(--
		DUP 0< ABORT" STACK underflow"
		\ this version if you don't allow the option "reg offset scale"
		DUP 1 CELLS >  ABORT" STACK overflow"

		\ ?? pfa addr items*cells(--
		OVER #_mode + C@ ABORT" Mode used"
		ROT W@ jump #_mode + C!
		\ ?? addr items*cells(--
		\ #### I do not like this rule, it is better to have one rule
		\ offset before register scale after.
		4 = IF
			DUP #_reg + @ IF
				#_scale + !
			ELSE
				#_displacement + !
			THEN
		ELSE
			DROP
		THEN
		-1 %indirection +! 
		%indirection @ not IF
			1 %field +!
		THEN
	;

( The #_flag encoding is 01 << 02 >> 04 & )
: _!flags ( code --)
	%indirection @ #ef_entryASL LSHIFT   \ code indirection (--
	%field @ #num_fields < not ABORT" To many fields"  \ code indirections(--
	%field @ 
	#ef_fieldASL LSHIFT   \ code indirection field (--
	+ %ef_table + #_flags + \ code addr(--
	DUP C@ \ code addr old(--
	ROT OR SWAP
	C!
;


forth : _flags 
	assembler
	(CREATE) tw, DOES> 
		W@ _!flags
;

( defining word for W. L. B. )
( The #_size encoding is 0 = not set 1 = B. 2 = W. 3 = L.)
: !size ( code --)
	%indirection @ #ef_entryASL LSHIFT   \ code indirection (--
	%field @ #num_fields < not ABORT" To many fields"  \ code indirections(--
	%field @ #ef_fieldASL LSHIFT   \ code indirection field (--
	+ %ef_table + #_size + \ code addr(--
	C!
;


forth : SIZE 
	assembler
	(CREATE) tw, DOES> 
		W@ !size 
;

( size codes) 
binary
						   0001 EQU ___L
0010 EQU __W_              0011 EQU __WL
0100 EQU _B__              0101 EQU _B_L
0110 EQU _BW_              0111 EQU _BWL
1000 EQU N___              1001 EQU N__L
1010 EQU N_W_              1011 EQU N_WL
1100 EQU NB__              1101 EQU NB_L
1110 EQU NBW_              1111 EQU NBWL

( assembler table offsets)
| zero    DUP CONSTANT   #at_ef0    1+
|         DUP CONSTANT   #at_ef1    1+
|         DUP CONSTANT   #at_ef2    1+
|         DUP CONSTANT   #at_ef3    1+
|         DUP CONSTANT   #at_spare  1+
|         DUP CONSTANT   #at_flags  1+  ( contains # code also)
|         DUP CONSTANT   #at_cpu    1+
|         DUP CONSTANT   #at_group  1+
|         DUP CONSTANT   #at_opcode 2+
|         DUP CONSTANT   #at_ext    2+
|             CONSTANT   #at_entry_length

	( address sets) 
	HEX
	| CREATE ||
	 #.Dn                tc,   
	 #.An                tc,
	 #.[An]              tc,   
	 #.[An]+             tc,
	 #.[An-]             tc,   
	 #.[n16.An]          tc,
	 #.[n16]             tc,   
	 #.[n32]             tc,
	 #.#                 tc,   
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,   
	 #.[n.PC]            tc,   
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,   
	-1 tc,

	| CREATE ||
	 #.Dn                tc,   
	 #.An                tc,
	 #.[An]              tc,   
	 #.[An]+             tc,
	 #.[An-]             tc,   
	 #.[n16.An]          tc,
	 #.[n16]             tc,   
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,   
	-1 tc,

	| CREATE ||
	 #.[An]              tc,   
	 #.[An]+             tc,
	 #.[An-]             tc,   
	 #.[n16.An]          tc,
	 #.[n16]             tc,   
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,   
	-1 tc,

	| CREATE ||
	 #.Dn               tc,
	 #.[An]             tc,   
	 #.[An]+            tc,
	 #.[An-]            tc,   
	 #.[n16.An]         tc,
	 #.[n16]            tc,   
	 #.[n32]            tc,
	 #.[n8.An.In.1]     tc,
	 #.[n8.An.In.sc]    tc,   
	-1 tc,

	| CREATE ||
	 #.[An]              tc,
	 #.[An-]             tc,  
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	-1 tc,

	| CREATE ||
	 #.[An]              tc,  
	 #.[An]+             tc,
	 #.[An-]             tc,  
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE ||
	 #.Dn                tc,
	 #.[An]              tc,  
	 #.[An]+             tc,
	 #.[An-]             tc,  
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.#                 tc,  
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE ||
	 #.[An]              tc,
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE ||
	 #.[An]              tc,  
	 #.[An]+             tc,
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE ||
	 #.Dn                tc,
	 #.[An]              tc,
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	-1 tc,

	| CREATE ||
	 #.Dn                tc,
	 #.[An]              tc,
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.#                 tc,  
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE ||
	 #.[An]              tc,
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	-1 tc,

	| CREATE ||
	 #.[An]              tc,  
	 #.[An]+             tc,
	 #.[An-]             tc,  
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.#                 tc,  
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE ||
	 #.[An]              tc,
	 #.[An-]             tc,  
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE ||
	 #.Dn                tc,
	 #.[An]              tc,  
	 #.[An]+             tc,
	 #.[An-]             tc,  
	 #.[n16.An]          tc,
	 #.[n16]             tc,  
	 #.[n32]             tc,
							  
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,  
	 #.[n.PC]            tc,  
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,  
	-1 tc,

	| CREATE |Dn|
	#.Dn tc,
	-1 tc,

	| CREATE |[An-]|
	#.[An-] tc,
	-1 tc,

	| CREATE |<#>|
	#.# tc,
	-1 tc,

	| CREATE ||
	#.CCR tc,
	-1 tc,

	| CREATE ||
	#.ACC tc,
	-1 tc,

	| CREATE ||
	#.MASK tc,
	-1 tc,


	| CREATE ||
	#.MACSR tc,
	-1 tc,

	| CREATE |Rn|
	#.Dn    tc,
	#.An    tc,
	-1 tc,

	| CREATE ||  
	#.caches tc,  
	-1 tc,

	| CREATE |[An]|      
	#.[An]   tc,  
	-1 tc,

	| CREATE |An|        
	#.An     tc,  
	-1 tc,

	| CREATE ||      
	#.SR     tc,  
	-1 tc,

	| CREATE ||    
	#.cond   tc,  
	-1 tc,

	| CREATE |[An]+|
	#.[An]+ tc,
	-1 tc,

	| CREATE ||
	#.USP tc,
	-1 tc,

	| CREATE ||
	#.[n16] tc,
	#.[n32] tc,
	-1 tc,

	| CREATE ||
	#.[n.PC] tc,
	-1 tc,

	| CREATE |Rc|
	#.USP tc,
	#.Rc tc,
	-1   tc,

	| CREATE |Rlist|
	#.Rlist tc,
	-1 tc,

	| CREATE |[n16An]|
	#.[n16.An]  tc,
	-1 tc,

	| CREATE |null|
	#.null tc,
	-1 tc,


	\ additional coldfire mode
	\ MMOV register-to-memory
	\ MMOV memory-to-register
	| CREATE ||
	 #.[An]              tc,
	 #.[n16.An]          tc,
	-1 tc,

	\ additional coldfire mode BCLR BSET eC, bit number is immediate
	\ effective address is destination
	| CREATE ||
	 #.[An]              tc,   #.[An]+             tc,
	 #.[An-]             tc,   #.[n16.An]          tc,
	-1 tc,

	\ additional coldfire mode BCLR BSET etc. bi number in data register
	| CREATE ||
	 #.[An]              tc,   #.[An]+             tc,
	 #.[An-]             tc,   #.[n16.An]          tc,
	 #.[n16]             tc,   #.[n32]             tc,
	-1 tc,

	| CREATE ||
	 #.Dn                tc,   
	 #.[An]              tc,   #.[An]+             tc,
	 #.[An-]             tc,  
	-1 tc,

	| CREATE ||
	 #.[n16.An]          tc,
	 #.[n.PC]            tc,   
	-1 tc,

	| CREATE ||
	 #.Dn                tc,   
	 #.[An]              tc,   #.[An]+             tc,
	 #.[An-]             tc,   #.[n16.An]          tc,
	-1 tc,

	| CREATE ||
 
	 #.[n16]             tc,   
	 #.[n32]             tc,
	 #.#                 tc,
	 #.[n8.An.In.1]      tc,
	 #.[n8.An.In.sc]     tc,   
	 #.[n.PC.In.1]       tc,
	 #.[n.PC.In.sc]      tc,   
	-1 tc,

	| CREATE ||
	 #.Dn                tc,   
	 #.#                 tc,   
	-1 tc,

	\ used when creating forth. The address has to be 32 bits so it can be
	\ altered by DOES> and ;code as required. While 16 bit and 32 bit AB 
	\ accepted, the instruction compiling word forces things to long.
	\ See INSTRUCTION JSR
	| CREATE ||
	#.[n16]              tc,    #.[n32]           tc,
	-1 tc,

	| CREATE ||
	 #.Dn                tc,  
	 #.An                tc, 
	 #.#                 tc,   
	-1 tc,


	\ has to end on word boundry
	0 ALLOT

	.S .( ef_error)
	( ef_error)

	| : ef_error ( --)
	  00 06 (system_error) ;

	( address set codes)
	zero
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU   		4+
	DUP EQU       	4+
	DUP EQU          	4+
	DUP EQU Dn             	4+
	DUP EQU [An-]          	4+
	DUP EQU <#>            	4+
	DUP EQU           	4+
	DUP EQU            4+
	DUP EQU           4+
	DUP EQU          4+
	DUP EQU            	4+
	DUP EQU          	4+
	DUP EQU Rn             	4+
	DUP EQU        	4+
	DUP EQU null           	4+
	DUP EQU [An]   			4+
	DUP EQU An     			4+
	DUP EQU [An]+  			4+
	DUP EQU   			4+
	DUP EQU    			4+
	DUP EQU    			4+
	DUP EQU Rc     			4+
	DUP EQU Rlist  			4+
	DUP EQU [n16An] 		4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	DUP EQU           4+
	4/  EQU #num_ef_sets

	.S .( )
	( address set vector table)
	| CREATE no_set
	-1  tc,

	| CREATE 
	no_set #num_ef_sets init_vectors
 
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||     		  		4/  add_vector
	||          	         	4/  add_vector
	||          	         	4/  add_vector
	|Dn|              	Dn             	4/  add_vector
	|[An-]|           	[An-]          	4/  add_vector
	|<#>|             	<#>            	4/  add_vector
	||           	          	4/  add_vector
	||           	          	4/  add_vector
	||           	          4/  add_vector
	||                    4/  add_vector
	||            	           	4/  add_vector
	||          	         	4/  add_vector
	\ |{offset.width}|  	{offset.width} 	4/  add_vector
	|Rn|              	Rn             	4/  add_vector
	||        	       	4/  add_vector
	|[An]|           	[An]           	4/  add_vector
	|null|            	null           	4/  add_vector
	|An|               	An          	4/  add_vector
	|[An]+|            	[An]+       	4/  add_vector
	||            	       	4/  add_vector
	||             	        	4/  add_vector
	||             	        	4/  add_vector
	|Rc|               	Rc          	4/  add_vector
	|Rlist|            	Rlist       	4/  add_vector
	|[n16An]|          	[n16An]     	4/  add_vector
	( reduced modes added for coldfire)
	||                      4/  add_vector
	||                      4/  add_vector
	||                      4/  add_vector
	||                      4/  add_vector
	||                      4/  add_vector
	||                      4/  add_vector
	||                      4/  add_vector
	||                      4/  add_vector
	\  without #.[n16] used for L. JSR 
	||     		  		4/  add_vector
	||                      4/  add_vector


	: get_size ( --code)
		%field @ #num_fields < not ABORT" To many fields"  \ code indirections(--
		%field @ #ef_fieldASL LSHIFT   \ code indirection field (--
		%ef_table + \ code addr(--
		#_size +
		C@ ?DUP IF
			EXIT
		THEN
		%field @  1 - zero MAX #ef_fieldASL LSHIFT   \ code indirection field (--
		%ef_table + \ code addr(--
		#_size +
		C@ 			
	;


	\ shift factor is placed after destination
	\ and is contained in low two bits of flags
	: get_sf ( --code)
		#Freg #ef_fieldASL LSHIFT   \ code indirection field (--
		%ef_table + \ code addr(--
		#_flags +
		C@ 
		03 AND
	;

	\ code is 0 or 1
	\ the & is placed after the F reg
	: get&  ( --code)
		#Wreg #ef_fieldASL LSHIFT   \ code indirection field (--
		%ef_table + \ code addr(--
		#_flags + C@ 04 AND 2 RSHIFT
	;
	
	: get_ul_source ( --code)
		#dest #ef_fieldASL LSHIFT   \ code indirection field (--
		%ef_table + \ code addr(--
		#_flags + C@ 08 AND 3 RSHIFT
	;

	: get_ul_dest ( --code)
		#Freg #ef_fieldASL LSHIFT   \ code indirection field (--
		%ef_table + \ code addr(--
		#_flags + C@ 08 AND 3 RSHIFT
	;


	: reg>BA9876543210 ( opcode data -- 16b)
		0FFF AND
		OR
	;


	: reg>76  ( opcode data -- 16b)
		03 AND
		6 LSHIFT
		OR
	;

	: get_opcode ( table --16b)
		#at_opcode + W@
	;

	: get_ext ( table --16b)
		#at_ext + W@ 
	;



	| : #>BA9 ( opcode data -- opcode)
		07 AND
		9 LSHIFT
		OR
	;

	| : #>BA9n2 ( opcode data -- opcode)
		DUP 0> IF
			07 AND
			9 LSHIFT
		 	OR
		ELSE
			\ If -1 leave as zero
			DROP
		THEN
	;

	| : #>76543210 ( opcode data --opcode)
		0FF AND
		OR
	;


	| : #>3210 ( opcode data --opcode)
		0F AND
		OR
	;


	| : #>210 ( opcode data --opcode)
		07 AND
		OR
	;


	| :  cond>BA98  ( opcode cond --opcode)
		0F AND
		8 LSHIFT
		OR
	;


	| : reg>210 ( opcode reg -- opcode)
		#reg_number AND
		OR
	;


	| : reg>876 ( opcode reg -- opcode)
		#reg_number AND
		6 LSHIFT
		OR
	;


	| : reg>BA9 ( opcode reg -- opcode)
		#reg_number AND
		9 LSHIFT
		OR
	;

	: reg>EDC ( opcode reg -- opcode)
		#reg_number AND
		0C LSHIFT
		OR
	;

	: reg>FEDC ( opcode reg -- opcode)
		#set® AND
		0C LSHIFT
		OR
	;

	: reg>3210 ( opcode reg -- opcode)
		#set® AND
		OR
	;

	: reg>6BA9 ( opcode reg -- opcode)
		#set® AND
		DUP #reg_number AND
		9 LSHIFT
		SWAP 
		#reg_set AND
		3 LSHIFT
		OR
		OR
	;
	 
	: reg>FEDC ( opcode reg -- opcode)
		#set® AND
		0C LSHIFT
		OR
	;
	


	: get_reg_source ( --16b)
		#source #ef_fieldASL LSHIFT   \ indirection field (--
		%ef_table  + \ addr(--
		DUP #_code +
		C@
		\ addr code(--
		code>regoffset + C@ DUP 0FF = ABORT" System error, get_index_register"
		\ addr offset(--
		+ #_reg +
		W@
	; 


	: get_reg_dest ( --16b)
		#dest #ef_fieldASL LSHIFT   \ indirection field (--
		%ef_table + \ addr(--
		DUP #_code +
		C@
		\ addr code(--
		code>regoffset + C@ DUP 0FF = ABORT" System error, get_index_register"
		\ addr offset(--
		+ #_reg +
		W@
	; 


	: get_reg_F ( --16b)
		#Freg #ef_fieldASL LSHIFT   \ indirection field (--
		%ef_table + \ addr(--
		DUP #_code +
		C@
		\ addr code(--
		code>regoffset + C@ DUP 0FF = ABORT" System error, get_index_register"
		\ addr offset(--
		+ #_reg +
		W@
	; 

	: get_reg_W ( --16b)
		#Wreg #ef_fieldASL LSHIFT   \ indirection field (--
		%ef_table + \ addr(--
		DUP #_code +
		C@
		\ addr code(--
		code>regoffset + C@ DUP 0FF = ABORT" System error, get_index_register"
		\ addr offset(--
		+ #_reg +
		W@
	; 



	: get_AB_source ( --32b)
		 %ef_table  [ #ef_entry_length #_displacement + ]T LITERAL +  @ 
	;



	: get_AB_dest ( --32b)
		 %ef_table  [ #ef_entry_length #ef_field_length + #_displacement + ]T LITERAL + @ 
	;


	: get_AB_F ( --32b)
		%ef_table  [ #ef_entry_length  #_displacement + #ef_field_length 2* + ]T LITERAL @ 
	;


	: get_#_source ( --32b)
		 %ef_table [ #_displacement ]T LITERAL + @ 
	;


	: get_#_dest ( --32b)
		 %ef_table  [ #ef_field_length #_displacement + ]T LITERAL + @ 
	;


	: get_#_F ( --32b)
		 %ef_table  [ #ef_field_length 2*  #_displacement + ]T LITERAL + @ 
	;



	\ used as @EXECUTE table, table contains xt values
	| CREATE ,table
		 ' X, t,    ' XW, t,    ' XW, t,  ' X, t,

	| : ,immediate ( value size --)
	  4* ,table + @execute ;

	(  All the size> words expect:           )
	(  0 = no spec 1 = byte 2 = word 3 = long)

	| CREATE 76encode  80 tc, 00 tc, 40 tc, 80 tc,

	| : size>76 ( opword size -- opword)
		76encode + C@ OR
	;

	| CREATE 8encode 100 tw, 000 tw, 000 tw, 100 tw,

	| : size>8 ( opword size -- opword
		2* 8encode + W@ OR
	;

	| CREATE DCencode  2000 tw, 1000 tw, 3000 tw, 2000 tw,

	| : size>DC ( opword size --opword)
		2* DCencode + W@ OR
	;

	| CREATE 6encode 40 tc, 00 tc, 00 tc, 40 tc,

	| : size>6 ( opword size --opword)
		6encode + C@ OR
	;



	| CREATE a6encode 00 tc, 00 tc, 40 tc, 00 tc,

	| : asize>6 ( opword size --opword)
		a6encode + C@ OR
	;

	| CREATE a9encode 0600 tw, 0200 tw, 0400 tw, 0600 tw,

	| : size>a9 ( opword size --opword)
		2* a9encode + W@ OR
	;

	| CREATE A9encode 0400 tw, 0000 tw, 0200 tw, 0400 tw,


	| : size>A9 ( opword size --opword)
		2* A9encode + W@ OR
	;

	
	| CREATE Bencode 0800 tw, 0000 tw, 0000 tw, 0800 tw,
	| : size>B ( opword size --opword)
		2* Bencode + W@ OR
	;



	( calculate relative)  HEX
	: (branch_rel)  ( value ahere size --)
		%xh @ %ximage -   \ number of bytes in ximage
		\ value ahere size image_size(--
		ROT +
		\ value size pc_address(--
		SWAP -rot -  \ size offset(--
		DUP -8000 < IF
			NIP #long EXIT
		THEN
		DUP 7FFF > IF
			NIP #long EXIT
		THEN
		DUP -1 = IF ( long code)
			NIP #long EXIT
		THEN
		\ forced long
		OVER #long = IF
			SWAP EXIT
		THEN
		DUP -80 < IF
			NIP #word EXIT
		THEN
		DUP 7F > IF
			NIP #word EXIT
		THEN
		\ word code
		DUP 0= IF
			NIP #word EXIT
		THEN
		OVER #word = IF
			SWAP EXIT
		THEN
		NIP #byte
	;

	| : branch_rel ( value -- rel code)
	  ahere get_size (branch_rel) DUP #long = IF
		 %cpu @ #long_branch AND not
		 ABORT" Long branch not supported by CPU."
	  THEN ;

	: (PC_rel)  ( value ahere -- rel code)
		%xh @ %ximage - + \ value PC
		-                 \ offset
		DUP -8000 < IF
			#long EXIT
		THEN
		DUP 7FFF > IF
			#long EXIT
		THEN
		DUP -80 < IF
			#word EXIT
		THEN
		DUP 7F > IF
			#word EXIT
		THEN
		DUP 00 = IF
			#word EXIT
		THEN
		#byte 
	;


	| : PC_rel ( value --rel code)
	  ahere (PC_rel) DUP #long = IF
		%cpu @ #long_PC AND not
		ABORT" Long PC rel not supported by CPU."
	  THEN ;

	( effective address extension constants) HEX
	0100 EQU #full_extension
	0080 EQU #no_base
	0040 EQU #no_index
	0010 EQU #null_disp
	0020 EQU #word_disp
	0030 EQU #long_disp
	0004 EQU #post_index
	0000 EQU #pre_index
	0001 EQU #null_outer
	0002 EQU #word_outer
	0003 EQU #long_outer

	( effective address constants ) binary
	001000  CONSTANT An_mode
	010000  CONSTANT [An]_mode
	011000  CONSTANT [An]+_mode
	100000  CONSTANT [An-]_mode
	101000  CONSTANT [n16An]_mode
	110000  CONSTANT [nAnInsc]_mode
	111000  CONSTANT [n16]_mode
	111001  CONSTANT [n32]_mode
	111010  CONSTANT [n16PC]_mode
	111011  CONSTANT [nPCInsc]_mode
	111100  CONSTANT [#]_mode

	HEX


	: !Dn ( addr --)
		#_reg + W@
		#reg_number AND
		%ximage W@ OR
		%ximage W!
	;


	: !An ( addr --)
		#_reg + W@
		#reg_number AND
		An_mode OR
		%ximage W@ OR
		%ximage W!
	;


	: ![An] ( addr --)
		#_reg #ef_entry_length + + W@
		#reg_number AND
		[An]_mode OR
		%ximage W@ OR
		%ximage W!
	;


	: ![An]+ ( addr --)
		#_reg #ef_entry_length + + W@
		#reg_number AND
		[An]+_mode OR
		%ximage W@ OR
		%ximage W!
	;


	: ![An-] ( addr --)
		#_reg #ef_entry_length + + W@
		#reg_number AND
		[An-]_mode OR
		%ximage W@ OR
		%ximage W!
	;


	: ![n16An] ( addr --)
		DUP [ #_reg #ef_entry_length + ]T LITERAL + W@
		#reg_number AND
		[n16An]_mode OR
		%ximage W@ OR
		%ximage W!

		#_displacement #ef_entry_length + + @
		%xh @ W!
		2 %xh +!

	;


	: ![n16] ( addr --)
		[n16]_mode 
		%ximage W@ OR
		%ximage W!

		[ #_displacement #ef_entry_length + ]T LITERAL + @
		%xh @ W!
		2 %xh +!

	;

	: ![n32] ( addr --)
		[n32]_mode 
		%ximage W@ OR
		%ximage W!

		[ #_displacement #ef_entry_length + ]T LITERAL + @
		%xh @ !
		4 %xh +!

	;

	| CREATE size_table
	0800 tw, ( 0 = N, the default is long)
	0000 tw, ( 1 = B should not be)
	0000 tw, ( 2 = W )
	0800 tw, ( 3 = L )


	| CREATE scale_table
	0000 tw, ( 0) 0000 tw, ( 1) 0200 tw, ( 2) 0200 tw, ( 3)
	0400 tw, ( 4) 0400 tw, ( 5) 0400 tw, ( 6) 0400 tw, ( 7)
	0600 tw, ( 8)

	( Only 01,2,4  should occure)
	: ![n8AnInsc] ( addr --)
		[ #_reg #ef_entry_length + ]T LITERAL OVER + W@
		#reg_number AND
		[nAnInsc]_mode OR
		%ximage W@
		OR
		%ximage W!

		\ addr(--
		[ #_index #ef_entry_length + ]T LITERAL OVER + W@
		#set® AND
		0C LSHIFT

		\ addr 16b(--
		[ #_scale #ef_entry_length + ]T LITERAL jump + @ 2*
		scale_table + W@ OR

		\ addr 16b1(--
		[ #_size #ef_entry_length + ]T LITERAL jump + C@ 2*
		size_table + W@ OR

		\ addr 16b2(--
		[ #_displacement #ef_entry_length + ]T LITERAL jump + @
		0FF AND
		OR

		\ addr 16b3(--
		%xh @ W!
		2 %xh +!
		
		DROP
	;



	: (![#]) ( addr size --)
		%ximage W@ 
		[#]_mode OR
		%ximage W!
		OVER #_displacement + @
		\ addr size value(--
		OVER #byte = IF
			DUP FF > IF
				ABORT" Immediate out of range byte expected"
			THEN
			DUP -80 < IF
				ABORT" Immediate out of range byte expected"
			THEN
			%xh @
			W!
			2 %xh +!
			2DROP
			EXIT
		THEN
		OVER #word = IF
			DUP FFFF > IF
				ABORT" Immediate out of range word expected"
			THEN
			DUP -8000 < IF
				ABORT" Immediate out of range word expected"
			THEN
			%xh @
			W!
			2 %xh +!
			2DROP
			EXIT
		THEN
		%xh @ 
		!
		4 %xh +!
		2DROP
		EXIT
	;


	| : ![#] ( addr --)
		get_size (![#]) ;


	: {![n16PC]} ( addr offset --)
		%ximage W@
		[n16PC]_mode OR
		%ximage W!
		%xh @ W!
		2 %xh +!
	;

	: {![n8PCInsc]} ( addr offset --)
		SWAP
		%ximage W@ 
		[nPCInsc]_mode OR
		%ximage W!

		\ offset addr(--
		[ #_index #ef_entry_length + ]T LITERAL OVER + W@
		#set® AND
		12 LSHIFT

		\ offset addr 16b(--
		[ #_scale #ef_entry_length + ]T LITERAL jump + @ 2*
		scale_table + W@ OR

		\ offset addr 16b
		[ #_size #ef_entry_length + ]T LITERAL jump + C@ 2*
		size_table + W@ OR

		\ offset addr 16b(--
		ROT 0FF AND OR
		\ addr 16b(--
		%xh @ W!
		2 %xh +!

		DROP
	;


	| : ![nPC] ( table --)
		DUP [ #_displacement #ef_entry_length +  ]T LITERAL +
		@ PC_rel ( addr offset code--)
		#long = ABORT" PC offset to large"
		{![n16PC]} 
	;

	| : ![nPCInsc] ( table --)
		DUP [ #_displacement #ef_entry_length + ]T LITERAL +
		@ PC_rel ( addr offset code--)
		#byte <> ABORT" PC relative index mode, offset error."
		{![n8PCInsc]} 
	;


	( wrong_code)
	| : wrong_code ( --)
		ABORT" System error, effective address code wrong"
	;

	\ used as a vector table, contains xt values
	( effective address vectors)
	| CREATE !ef_vectors

	' wrong_code #.num_test_sets init_vectors

	' !Dn             #.Dn            !ef_vectors add_vector
	' !An             #.An            !ef_vectors add_vector
	' ![An]           #.[An]          !ef_vectors add_vector
	' ![An]+          #.[An]+         !ef_vectors add_vector
	' ![An-]          #.[An-]         !ef_vectors add_vector
	' ![n16An]        #.[n16.An]      !ef_vectors add_vector
	' ![n16]          #.[n16]         !ef_vectors add_vector
	' ![n32]          #.[n32]         !ef_vectors add_vector
	' ![#]            #.#             !ef_vectors add_vector
	' ![n8AnInsc]     #.[n8.An.In.1]  !ef_vectors add_vector
	' ![n8AnInsc]     #.[n8.An.In.sc] !ef_vectors add_vector
	' ![nPC]         #.[n.PC]           !ef_vectors add_vector
	' ![nPCInsc]     #.[n.PC.In.1]      !ef_vectors add_vector
	' ![nPCInsc]     #.[n.PC.In.sc]     !ef_vectors add_vector




| : ef>543210 ( field_code--)
  field_address
  DUP #_code + C@ !ef_vectors vector ;


\ the register and mode fields have to be swapped
:  (543210>BA9876) ( opcode efcode -- opcode)
	DUP 07 AND \ register field
	9 LSHIFT
	\ opcode efcode reg
	ROT OR
	SWAP
	\ opcode effield(--	
	38 AND 
	3 LSHIFT
	OR
; 


| : ef>BA9876 ( code --)
  %ximage W@ ( get instruction to date) SWAP
  OVER FFC0 AND %ximage W!  field_address
  DUP #_code + C@ !ef_vectors vector
  %ximage W@ (543210>BA9876)
  %ximage W! ;



( assembler words)
( There is a word to assemble each group of instructions)


\ i = bit from op code
\ S = Source data
\ D = Destination data
\ F = Third field
\ C = conditional code
\ r = relative address
\ W = Width data
\ O = Offset data
\ # = # data



| : (i16) ( table --)
	get_opcode XW,  ;

| : (i16+#16) ( table--)
	 get_opcode XW,
	 get_#_source XW, ;

| : (i16+#32) ( table--)
	 get_opcode XW,
	 get_#_source X, ;

| : (i4C4i8+#) ( table--)
	 get_opcode get_reg_dest cond>BA98 XW,
	 get_#_source get_size ,immediate ;

| : (i4C4i8) ( table--)
	 get_opcode get_reg_source cond>BA98 XW, ;

| : (i4C4i2S6) ( table --)
	 get_opcode get_reg_dest   cond>BA98 XW,
	 #source ef>543210 ;

| : (i13S3) ( table --)
	get_opcode get_reg_source reg>210 XW,   ;

| : (i13S3+#) ( table --)
  get_opcode get_reg_source   reg>210 XW,
  get_#_dest get_size ,immediate ;

| : (i13S3+#16) ( table)
  get_opcode get_reg_source   reg>210 XW,
  get_#_dest XW, ;

| : (i13S3+AB) ( table --)
  get_opcode get_reg_source   reg>210 XW,
  get_AB_dest   X, ;

| : (i13D3+AB) ( table --)
  get_opcode get_reg_dest     reg>210 XW,
  get_AB_source X, ;

| : (i13D3) ( table --)
	get_opcode get_reg_dest reg>210 XW,  ;


| : (i13#3) ( table --)
	get_opcode get_#_source #>210 XW, ;

( Used for Dn CLR)
| : (i4S3i9) ( table --)
	get_opcode
	get_reg_source reg>BA9
	XW, ;

| : (i4S3i6S3) ( table --)
  get_opcode
  get_reg_source reg>210
  get_reg_source reg>BA9  XW, ;

| : (i4D3s1i5D3) ( table --)
  get_opcode
  get_reg_dest   reg>210
  get_reg_dest   reg>BA9
  get_size size>8 XW,  ;

| : (i4S3i6D3) ( table --)
  get_opcode
  get_reg_dest   reg>210
  get_reg_source reg>BA9 XW,  ;

| : (i4D3i1s2i3S3)  ( table --)
  get_opcode
  get_reg_source reg>210
  get_reg_dest   reg>BA9
  get_size       size>76 XW,
 ;

| : (i4S3i1s2i3D3)  ( table --)
  get_opcode
  get_reg_dest     reg>210
  get_reg_source   reg>BA9
  get_size         size>76 XW,
 ;

| : (i4#3i1s2i3D3) ( table --)
  get_opcode
  get_reg_dest     reg>210
  get_#_source     #>BA9
  get_size         size>76 XW,
 ;

| : (i4D3i1#8) ( table --)
  get_opcode
  get_reg_dest reg>BA9
  get_#_source #>76543210
  XW,  ;

| : (i12#4) ( table --)
  get_opcode
  get_#_source #>3210
  XW,  ;


( BCC )
( This handles label CC BCC)
( We use  HERE 2+ AB CC Bcc to force 16bit extension if offset)
( is to be loaded later.)
(         HERE CC Bcc will result in 8bit version.)
(         HERE 1+ CC Bcc forces 32 bit version.)

| : (a_BCC) ( addr table --)
  get_opcode
  get_reg_source cond>BA98  XW,
  branch_rel DUP #byte = IF
	 DROP 0FF AND %ximage W@ OR %ximage W! EXIT 
  THEN
  DUP #word = IF
	 DROP XW, EXIT 
  THEN
  #long = IF
	 %ximage W@ 0FF OR %ximage W! X, EXIT 
  THEN
  00 03 (system_error)  ;

( [ addr ] CC BCC )
| : (b_BCC) ( table --)
  get_opcode
  get_reg_dest cond>BA98  XW,
  get_AB_source
  branch_rel DUP #byte = IF
	 DROP 0FF AND %ximage W@ OR %ximage W! EXIT THEN
  DUP #word = IF
	 DROP XW, EXIT 
  THEN
  ( must be long)
  #long = IF
	 %ximage W@ 0FF OR %ximage W! X, EXIT THEN
  00 03 (system_error) ;

( addr BRA  or addr BSR )
| : (a_BRANCH) ( addr table --)
  get_opcode
  XW,
  branch_rel DUP #byte = IF
	 DROP 0FF AND %ximage W@ OR %ximage W! EXIT THEN
  DUP #word = IF
	 DROP XW, EXIT THEN
  ( must be long)
  #long = IF
	 %ximage W@ 0FF OR %ximage W! X, EXIT THEN
  00 03 (system_error) ;

( [ addr ] CC BCC )
| : (b_BRANCH) ( table --)
  get_opcode
  XW,
  get_AB_source
  branch_rel DUP #byte = IF
	 DROP 0FF AND %ximage W@ OR %ximage W! EXIT THEN
  DUP #word = IF
	 DROP XW, EXIT THEN
  ( must be long)
  #long = IF
	 %ximage W@ 0FF OR %ximage W! X, EXIT THEN
  00 03 (system_error) ;

| : (i10S6) ( label --)
  get_opcode XW, #source ef>543210 ;

| : (L.i10S6) ( label --)
  \ this is used with L. JSR
  \ butcher act to force absolute address to 32 bits
  #.[n32] #source field_address #_code + C!
  get_opcode XW, #source ef>543210 ;

| : (W.i10S6) ( label --)
  #word !size
  get_opcode XW, #source ef>543210 ;

| : (i10D6) ( table --)
  get_opcode XW, #dest ef>543210 ;

| : (i8s2S6) ( table--)
  get_opcode
  get_size         size>76 XW,
  #source ef>543210 ;

| : (i8s2D6) ( table--)
  get_opcode
  get_size         size>76 XW,
  #dest  ef>543210 ;


| : (i4#3i3D6) ( table --)
  get_opcode
  get_#_source #>BA9 XW,
  #dest ef>543210 ;

| : (i4#3i3D6n2) ( table --)
  get_opcode
  get_#_source #>BA9n2 XW,
  #dest ef>543210 ;

| : (i4S3i3D6) ( table --)
  get_opcode
  get_reg_source reg>BA9 XW,
  #dest ef>543210 ;

| : (i4D3s1i2S6) ( table --)
  get_opcode
  get_reg_dest reg>BA9
  get_size size>8  XW,
  #source ef>543210 ;


| : (i4D3i2s1S6) (  table --)
	get_opcode
	get_reg_dest reg>BA9
	get_size     asize>6 XW, 
	 #source ef>543210   
	;



| : (i4D3i1s2S6) ( table --)
  get_opcode
  get_reg_dest reg>BA9
  get_size size>76 XW,
  #source ef>543210 ;

| : (i4D3i3S6) ( table --)
  get_opcode
  get_reg_dest reg>BA9 XW,
  #source ef>543210 ;

| : (W.i4D3i3S6) ( table --)
  #word !size  get_opcode
  get_reg_dest reg>BA9 XW,
  #source ef>543210 ;

| : (i4S3i1s2D6) ( table --)
  get_opcode
  get_reg_source reg>BA9
  get_size       size>76
  XW,  #dest ef>543210 ;

| : (i4#3i1s2D6) ( table --)
  get_opcode
  get_#_source #>BA9
  get_size size>76 XW,
  #dest ef>543210 ;

( ################ 1 or 2 words)
| : (i8s2D6+#) ( table --)
  get_opcode
  get_size size>76 XW,
  get_#_source get_size ,immediate
  #dest ef>543210 ;

| : (i10D6+#16) ( table --)
  get_opcode
  XW,
  get_#_source XW,
  #dest ef>543210 ;

| : (i2s2D6S6) ( table --)
  get_opcode
  get_size
  size>DC XW,
  #source ef>543210
  #dest   ef>BA9876 ;


: mirror ( 16b -- 16b)
	zero
	10 0 DO
		1 RSHIFT
		OVER 8000 AND IF
			8000 OR
		THEN
		SWAP 1 LSHIFT SWAP
	LOOP
	NIP
;

( Used by memory rl MOVM )
| : (i9s1S6+#) ( table --)
  get_opcode
  get_size size>6
  XW,
  get_#_dest XW,
  #source ef>543210 ;

| : (i9s1D6+#) ( table --)
  get_opcode
  get_size size>6
  XW,
  get_#_source XW,
  #dest ef>543210 ;

| : (1i9s1D6+#) ( table --)
  get_opcode
  get_size size>6
  XW,
  get_#_source mirror XW,
  #dest ef>543210 ;


| : (i10S6+i1F3i9D3) ( table --)
  DUP get_opcode XW,
  get_ext
  get_reg_F    reg>EDC
  get_reg_dest reg>210
  XW, #source ef>543210  ;

| : (i10S6+i1D3i9D3) ( table --)
  DUP get_opcode XW,
  get_ext
  get_reg_dest reg>EDC
  get_reg_dest reg>210
  XW, #source ef>543210  ;

| : (i13S3+i16) ( table --)
  DUP get_opcode get_reg_source reg>210 XW,
  get_ext
  XW,   ;

| : (i13S3+i1D3i12) ( table --)
  DUP get_opcode get_reg_source reg>210 XW,
  get_ext
  get_reg_dest reg>EDC
  XW,  ;

( Rc Rn MOVEC)
| : (i16+D4S12) ( type --)
  DUP get_opcode XW,
  get_ext
  get_reg_source reg>BA9876543210
  get_reg_dest   reg>FEDC XW, ;


( Rn Rc MOVEC)
| : (i16+S4D12) ( type --)
  DUP get_opcode XW,
  get_ext
  get_reg_dest   reg>BA9876543210
  get_reg_source reg>FEDC XW, ;

( Rn  MOVS )
| : (i8s2D6+S4i12) ( table --)
  DUP get_opcode
  get_size size>76 XW,
  get_ext
  get_reg_source reg>FEDC XW,
  #dest ef>543210 ;

(  Rn MOVS )
| : (i8s2S6+D4i12) ( table --)
  DUP get_opcode
  get_size size>76 XW,
  get_ext
  get_reg_dest reg>FEDC XW,
  #source ef>543210 ;


| : (mac) ( table--)
	DUP get_opcode  \ table opcode(--
	get_reg_source reg>6BA9
	get_reg_dest   reg>3210 XW,
	get_ext
	get_size size>B
	get_sf        9 LSHIFT OR
	get_ul_source 7 LSHIFT OR
	get_ul_dest   6 LSHIFT OR  XW,

;


| : (macl) ( table--)
	DUP get_opcode
	get_reg_W  reg>6BA9 XW,
	
	get_ext
	get_reg_source reg>FEDC
	get_reg_dest reg>3210
	get_size size>B
	get_sf        9 LSHIFT OR
	get_ul_source 7 LSHIFT OR
	get_ul_dest   6 LSHIFT OR  
	get&          5 LSHIFT OR XW,
	#Freg ef>543210
;

| : (i12D4) ( type --)
	get_opcode
	get_reg_dest reg>3210
	XW,
;

| : (i8S2i3D3) ( table --)
	get_opcode
	get_reg_source reg>76
	get_reg_dest   reg>210 XW,
;

\ | : (i8S2i6) ( table --)
\  get_opcode
\  get_reg_source reg>76 XW, ;

( This is for MOVP )
| : (i4S3i2s1i3D3+disp) (  table --)
  get_opcode
  get_reg_dest reg>210
  get_reg_source reg>BA9
  get_size     size>6  XW,
  get_AB_dest XW, ;

	| : (i4D3i2s1i3S3+disp) (  table --)
		get_opcode
		get_reg_dest reg>BA9
		get_reg_source reg>210	
		get_size     size>6  XW,
		get_AB_source XW, 
	;

	| : (i16+i16+#16) (  table --)
		DUP  get_opcode XW,
		get_ext    XW,
		get_#_source XW, 
	;

	| : (i10S6+i1D3i4s2i6)  ( table --)
		DUP get_opcode XW,
		get_ext
		get_reg_dest reg>EDC
		get_size     size>76 XW,
		#source ef>543210 
	;

	| : (i13S3+i1F3i4s2i3D3)  ( table --)
		DUP get_opcode get_reg_source reg>210 XW,
		get_ext get_reg_dest reg>210 get_reg_F reg>EDC
		get_size size>76 XW, 
	;

	: !reg ( value)
		%ef_table #_reg + W!
	;


	: @reg ( --value)
		%ef_table #_reg + W@
	;



	| : compliment_condition
		@reg 01 XOR !reg 
	;

	| : compile_branch ( addr --)
		ahere  OVER 2+ - ( branch size)
		DUP -80 80 WITHIN OVER 0<> AND IF ( 8bit)
			\ addr offset (--
			OVER aw@ 0FF AND DUP 0 = SWAP 0FF = OR not IF ( 8bit )
				OVER aw@ FF00 AND OR SWAP aw! EXIT 
			THEN 
		THEN
		DUP -8000 8000 WITHIN IF ( 16bit)
			\ addr offset(--
			OVER aw@ 0FF AND 0= IF ( 16bit desired)
				SWAP 2+ aw! EXIT 
			THEN 
		THEN
		OVER aw@ 0FF AND 0FF = IF ( 32bit desired)
			SWAP 2+ a! EXIT 
		THEN
		TRUE ABORT" Branch error." 
	;



	forth : OLD_TERMINATOR 
		assembler
		(CREATE) tw, DOES> ( pfa --)
		W@ \ pfa_value(--
		%indirection @ ABORT" Old and new syntax may not be used together"
		%field @ not ABORT" No register supplied"
		%field @ 1 - #ef_fieldASL LSHIFT %ef_table +
		\ pfa_value from(--
		DUP DUP #ef_entry_length +  
		\ pfa_value from from to (--
		#ef_entry_length MOVE
		\ pfa_value from(--
		\ cannot erase #_flags
		\ no need to erase #_flags
		DUP #_address_data ERASE
		\ pfa_value from(--
		#ef_entry_length + #_mode + C!
	;


	forth : OLD_DISPLACEMENT  
		assembler
		(CREATE) tw, DOES>  ( displacement pfa --)
			W@
			%field @ #ef_fieldASL LSHIFT
			%ef_table + #ef_entry_length +
			\ displacement pfa_data addr(--
			TUCK #_reg + W!
			#_] OVER #_mode + C!
			\ displacement addr(--
			#_displacement + !
			1 %field +!
		;
				



	( vector values) HEX
	zero
	DUP EQU  i16                 1+
	DUP EQU  i16+#16             1+
	DUP EQU  i16+#32             1+
	DUP EQU  i4C4i8+#            1+
	DUP EQU  i4C4i2S6            1+
	DUP EQU  i4C4i8              1+
	DUP EQU  i13S3               1+
	DUP EQU  i13D3               1+
	DUP EQU  i13#3               1+
	DUP EQU  i4S3i6D3            1+
	DUP EQU  i4S3i6S3            1+
	DUP EQU  i4D3s1i5D3          1+
	DUP EQU  i4D3i1s2i3S3        1+
	DUP EQU  i4S3i1s2i3D3        1+
	DUP EQU  i4#3i1s2i3D3        1+
	DUP EQU  i4S3i9              1+
	DUP EQU  i4D3i1#8            1+
	DUP EQU  i12#4               1+
	DUP EQU  a_BCC               1+
	DUP EQU  b_BCC               1+
	DUP EQU  a_BRANCH            1+
	DUP EQU  b_BRANCH            1+
	DUP EQU  i10S6               1+
	DUP EQU  W.i10S6             1+
	DUP EQU  L.i10S6             1+
	DUP EQU  i10D6               1+
	DUP EQU  i8s2S6              1+
	DUP EQU  i8s2D6              1+
	DUP EQU  i4#3i3D6            1+
	DUP EQU  i4#3i3D6n2          1+	
	DUP EQU  i4S3i3D6            1+
	DUP EQU  i4D3s1i2S6          1+
	DUP EQU  i4D3i1s2S6          1+
	DUP EQU  i4D3i2s1S6          1+
	DUP EQU  i4D3i3S6            1+
	DUP EQU  W.i4D3i3S6          1+
	DUP EQU  i4S3i1s2D6          1+
	DUP EQU  i4#3i1s2D6          1+
	DUP EQU  i8s2D6+#            1+
	DUP EQU  i10D6+#16           1+
	DUP EQU  i2s2D6S6            1+
	DUP EQU  i9s1D6+#            1+
	DUP EQU  i9s1S6+#            1+
	DUP EQU  1i9s1D6+#           1+
	DUP EQU i10S6+i1F3i9D3      1+
	DUP EQU i10S6+i1D3i9D3      1+
	DUP EQU i16+D4S12           1+
	DUP EQU i16+S4D12           1+
	DUP EQU  i8s2D6+S4i12       1+
	DUP EQU  i8s2S6+D4i12       1+
	DUP EQU  i8S2i3D3           1+
	DUP EQU  i13S3+i1D3i12      1+
	DUP EQU  i13S3+i1F3i4s2i3D3 1+
	DUP EQU  i13S3+#            1+
	DUP EQU  i13S3+#16          1+
	DUP EQU  i13D3+AB           1+
	DUP EQU  i13S3+AB           1+
	DUP EQU  i4S3i2s1i3D3+disp  1+
	DUP EQU  i4D3i2s1i3S3+disp  1+
	DUP EQU  i16+i16+#16        1+
	DUP EQU  i10S6+i1D3i4s2i6   1+
	DUP EQU i13S3+i16           1+
	DUP EQU  mac                1+
	DUP EQU  macl               1+
	DUP EQU  i12D4              1+
	EQU #num_!codes

	( default entry in vector table) HEX
	| : !code_error ( --)
		00  04 (system_error) 
	;

	\ table contins xt values
	( compile_vector)
	| CREATE (!code)

	' !code_error #num_!codes init_vectors

	' (i16)                 i16                  (!code) add_vector
	' (i16+#16)             i16+#16              (!code) add_vector
	' (i16+#32)             i16+#32              (!code) add_vector
	' (i4C4i8+#)            i4C4i8+#             (!code) add_vector
	' (i4C4i8)              i4C4i8               (!code) add_vector
	' (i4C4i2S6)            i4C4i2S6             (!code) add_vector
	' (i13S3)               i13S3                (!code) add_vector
	' (i13D3)               i13D3                (!code) add_vector
	' (i13#3)               i13#3                (!code) add_vector
	' (i4S3i6D3)            i4S3i6D3             (!code) add_vector
	' (i4S3i6S3)            i4S3i6S3             (!code) add_vector
	' (i4D3s1i5D3)          i4D3s1i5D3           (!code) add_vector
	' (i4D3i1s2i3S3)        i4D3i1s2i3S3         (!code) add_vector
	' (i4S3i1s2i3D3)        i4S3i1s2i3D3         (!code) add_vector
	' (i4#3i1s2i3D3)        i4#3i1s2i3D3         (!code) add_vector
	' (i4D3i1#8)            i4D3i1#8             (!code) add_vector
	' (i4S3i9)              i4S3i9               (!code) add_vector
	' (i12#4)               i12#4                (!code) add_vector
	' (a_BCC)               a_BCC                (!code) add_vector
	' (b_BCC)               b_BCC                (!code) add_vector
	' (a_BRANCH)            a_BRANCH             (!code) add_vector
	' (b_BRANCH)            b_BRANCH             (!code) add_vector
	' (i10S6)               i10S6                (!code) add_vector
	' (W.i10S6)             W.i10S6              (!code) add_vector
	' (L.i10S6)             L.i10S6              (!code) add_vector
	' (i10D6)               i10D6                (!code) add_vector
	' (i8s2S6)              i8s2S6               (!code) add_vector
	' (i8s2D6)              i8s2D6               (!code) add_vector
	' (i4#3i3D6)            i4#3i3D6             (!code) add_vector
	' (i4#3i3D6n2)           i4#3i3D6n2          (!code) add_vector

	' (i4S3i3D6)            i4S3i3D6             (!code) add_vector
	' (i4D3s1i2S6)          i4D3s1i2S6           (!code) add_vector
	' (i4D3i2s1S6)          i4D3i2s1S6           (!code) add_vector	
	' (i4D3i1s2S6)          i4D3i1s2S6           (!code) add_vector
	' (i4D3i3S6)            i4D3i3S6             (!code) add_vector
	' (W.i4D3i3S6)          W.i4D3i3S6           (!code) add_vector
	' (i4S3i1s2D6)          i4S3i1s2D6           (!code) add_vector
	' (i4#3i1s2D6)          i4#3i1s2D6           (!code) add_vector
	' (i8s2D6+#)            i8s2D6+#             (!code) add_vector
	' (i10D6+#16)           i10D6+#16            (!code) add_vector
	' (i2s2D6S6)            i2s2D6S6             (!code) add_vector
	' (i9s1S6+#)            i9s1S6+#             (!code) add_vector
	' (i9s1D6+#)            i9s1D6+#             (!code) add_vector
	' (1i9s1D6+#)            1i9s1D6+#           (!code) add_vector
	' (i10S6+i1F3i9D3)      i10S6+i1F3i9D3       (!code) add_vector
	' (i10S6+i1D3i9D3)      i10S6+i1D3i9D3       (!code) add_vector
	' (i16+D4S12)           i16+D4S12            (!code) add_vector
	' (i16+S4D12)           i16+S4D12            (!code) add_vector
	' (i8s2D6+S4i12)        i8s2D6+S4i12         (!code) add_vector
	' (i8s2S6+D4i12)        i8s2S6+D4i12         (!code) add_vector
	' (i8S2i3D3)            i8S2i3D3             (!code) add_vector
	' (i13S3+i1D3i12)       i13S3+i1D3i12        (!code) add_vector
	' (i13S3+i16)           i13S3+i16            (!code) add_vector
	' (i13D3+AB)            i13D3+AB             (!code) add_vector
	' (i13S3+AB)            i13S3+AB             (!code) add_vector
	' (i13S3+#)             i13S3+#              (!code) add_vector
	' (i13S3+#16)           i13S3+#16            (!code) add_vector
	' (i4S3i2s1i3D3+disp)   i4S3i2s1i3D3+disp    (!code) add_vector
	' (i4D3i2s1i3S3+disp)   i4D3i2s1i3S3+disp    (!code) add_vector
	' (i16+i16+#16)         i16+i16+#16          (!code) add_vector
	' (i10S6+i1D3i4s2i6)    i10S6+i1D3i4s2i6     (!code) add_vector
	' (i13S3+i1F3i4s2i3D3) i13S3+i1F3i4s2i3D3    (!code) add_vector
	' (mac)                 mac                  (!code) add_vector
	' (macl)                macl                 (!code) add_vector
 	' (i12D4)               i12D4               (!code) add_vector

	( size range) HEX
	

	: |#=#|  ( addr value --addr flag) 
		DROP FALSE 
	;

	
	\ TRUE failed
	: |0|  ( addr value --addr flag) 
		0<> 
	;

	: |1>8|  ( addr value --addr flag) 
		DUP 1 < IF
			DROP TRUE EXIT
		THEN
		DUP 08 > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;
	: |-1>7|  ( addr value --addr flag) 
		DUP -1 < IF
			DROP TRUE EXIT
		THEN
		DUP 07 > IF
			DROP TRUE EXIT
		THEN
		\ zero is not allowed also
		DUP 00 = IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;

	: |u3|  ( addr value --addr flag) 
		DUP 00 < IF
			DROP TRUE EXIT
		THEN
		DUP 07 > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;


	: |u4|  ( addr value --addr flag) 
		DUP 00 < IF
			DROP TRUE EXIT
		THEN
		DUP 0F > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;



	: |u5|  ( addr value --addr flag) 
		DUP 00 < IF
			DROP TRUE EXIT
		THEN
		DUP 01F > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;


	: |u8|  ( addr value --addr flag) 
		DUP 00 < IF
			DROP TRUE EXIT
		THEN
		DUP 0FF > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;


	: |n8|  ( addr value --addr flag) 
		DUP -80 < IF
			DROP TRUE EXIT
		THEN
		DUP 07F > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;


	: |n16|  ( addr value --addr flag) 
		DUP -8000 < IF
			DROP TRUE EXIT
		THEN
		DUP 07FFF > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;


	: |u16|  ( addr value --addr flag) 
		DUP 0< IF
			DROP TRUE EXIT
		THEN
		DUP 0FFFF > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;


	: |16b|  ( addr value --addr flag) 
		DUP -8000 < IF
			DROP TRUE EXIT
		THEN
		DUP 0FFFF > IF
			DROP TRUE EXIT
		THEN
		DROP
		FALSE
	;


	: vector_error  00 05 (system_error) ;

	( # codes) HEX
	10
	DUP EQU #=0          10 +
	DUP EQU #=1>8        10 +
	DUP EQU #=u3         10 +
	DUP EQU #=u4         10 +
	DUP EQU #=u5         10 +
	DUP EQU #=u8         10 +
	DUP EQU #=n8         10 +
	DUP EQU #=u16        10 +
	DUP EQU #=n16        10 +
	DUP EQU #=16b        10 +
	DUP EQU #=-1>7       10 +
	10 / #max_#vectors ??<


	\ contains xt
	( # vectors) HEX
	| CREATE #vectors
 
	 ' vector_error #max_#vectors init_vectors
 
	' |#=#|     0            #vectors add_vector
	' |0|       #=0     10 / #vectors add_vector
	' |1>8|     #=1>8   10 / #vectors add_vector
	' |u3|      #=u3    10 / #vectors add_vector
	' |u4|      #=u4    10 / #vectors add_vector
	' |u5|      #=u5    10 / #vectors add_vector
	' |u8|      #=u8    10 / #vectors add_vector
	' |n8|      #=n8    10 / #vectors add_vector
	' |u16|     #=u16   10 / #vectors add_vector
	' |n16|     #=n16   10 / #vectors add_vector
	' |16b|     #=16b   10 / #vectors add_vector
	' |-1>7|    #=-1>7  10 / #vectors add_vector


	\ TRUE then failed
	: check#  ( addr # addr -- addr flag)
		#at_flags + C@ 00F0 AND
		2 RSHIFT
		#vectors W@ 4* MIN
		#vectors + 2+ @execute
	;
	


	( flags are NBWL)
	| CREATE val>flag 08 tc, 04 tc, 02  tc, 01 tc,

	\ TRUE failed
	: test_size ( addr value flags --addr flag)
		SWAP val>flag + C@ AND 0=
	;
	


	( flag is true if not in set)
	: ?indataset ( addr value set -- addr flag )
		[  2+ ]T LITERAL + @  \ addr value set(--
		BEGIN
			2DUP C@ < IF \ failed
				2DROP
				TRUE 
				EXIT
			THEN
			2DUP C@ = IF \ this is it
				2DROP
				FALSE
				EXIT
			THEN
			1+
		AGAIN
	;


	( true all ok)
	| : test_conditions ( addr -- flag)
		%ef_table #_code + C@
		OVER #at_ef0 + C@  ?indataset IF
			DROP FALSE EXIT
		THEN
		%ef_table #_code + C@ #.# = IF
			%ef_table #_displacement + @ OVER 
			check# IF 
				DROP FALSE EXIT 
			THEN
		THEN
		%ef_table [ #ef_field_length  #_code + ]T LITERAL + C@
		OVER #at_ef1 + C@  ?indataset IF
			DROP FALSE EXIT
		THEN
		%ef_table [ #ef_field_length #_code + ]T LITERAL + C@
		#.# = IF
			%ef_table [ #ef_field_length #_displacement + ]T
			LITERAL + @ OVER check# IF
				DROP FALSE EXIT
			THEN 
		THEN
		%ef_table [ #ef_field_length 2* #_code + ]T LITERAL + C@
		OVER #at_ef2 + C@  ?indataset IF
			DROP FALSE EXIT
		THEN
		%ef_table [ #ef_field_length 2* #_code + ]T LITERAL + C@
		#.# = IF
			%ef_table [ #ef_field_length 2* #_displacement + ]T
			LITERAL + @ OVER  check# IF
				DROP FALSE EXIT 
			THEN 
		THEN
		%ef_table [ #ef_field_length  3 * #_code + ]T LITERAL + C@
		OVER #at_ef3 + C@  ?indataset IF
			DROP FALSE EXIT
		THEN
		%ef_table [ #ef_field_length 3 * #_code + ]T LITERAL + C@
		#.# = IF
			%ef_table [ #ef_field_length 3 * #_displacement + ]T
			LITERAL + @ OVER  check# IF
				DROP FALSE EXIT 
			THEN 
		THEN

		%ef_table [ #ef_field_length 4 * #_code + ]T LITERAL + C@
		#.null <> ABORT" Too many instruction modifiers."
		get_size  OVER #at_flags + C@ 0F AND test_size IF
			DROP FALSE EXIT
		THEN
		DUP  #at_cpu + C@  %cpu @ AND
		NIP 
	;

	( compile code)
	| : !code
		%xh @ %ximage -
		%ximage ahere jump agap ROT AMOVE 
	;


	| : compile_code ( addr --)
		DUP #at_group + C@ (!code) vector
		!code 
	;

	: INIT_ASSEMBLER ( --)
		%ximage #max_instruction ERASE
		%ximage %xh !
		zero %indirection !
		zero %field       !
		@s %ind_stack !
		%ef_table [ #ef_field_length #num_fields * ]T LITERAL ERASE 
	;



	: # ( value --)
		%indirection @
		#ef_entryASL LSHIFT  \ value offset(--
		%field @ #num_fields < not IF
			to_many_fields
		THEN
		%field @ #ef_fieldASL LSHIFT +        \ value offset2(--
		%ef_table +                            \ value addr(--
		#_# OVER #_mode + C@ OR OVER #_mode + C! \ value addr(--
		#_displacement + !
		1 %field +!
	;




forth : INSTRUCTION
	assembler
	(CREATE) DOES> 
		%ef_table                                     ef_code
		%ef_table #ef_field_length +                  ef_code
		%ef_table [ #ef_field_length 2*  ]T LITERAL + ef_code
		%ef_table [ #ef_field_length 3 * ]T LITERAL + ef_code
		%ef_table [ #ef_field_length 4 * ]T LITERAL + ef_code
		DUP C@ ( number of loops)  SWAP 2+ ( first entry)
		BEGIN
			DUP test_conditions   IF
				NIP compile_code  
				INIT_ASSEMBLER  EXIT 
			THEN
			#at_entry_length + SWAP 1- SWAP
			OVER not 
		UNTIL 
		2DROP
		INIT_ASSEMBLER
		TRUE  ABORT" Wrong instruction modifiers." 
	;


binary


INSTRUCTION ADD   0101 tc, 00 tc,

( ADDQ coldfire is long only )
<#>        tc,       tc, null tc, null tc, null tc, N__L #=1>8 + tc,
#all_68000 #all_coldfire +                 tc,      i4#3i1s2D6         tc,
0101000000000000    tw,  0000000000000000 tw,

( ADDI coldfire is long only and to data regiser only )
( his has to go first to cut out immediate data)
<#>        tc, Dn          tc, null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i8s2D6+#           tc,
0000011000000000    tw,  0000000000000000 tw,

( add to data register coldfire is long only but from all sources)
     tc, Dn          tc, null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4D3i1s2S6         tc,
1101000000000000    tw,  0000000000000000 tw,

( from data register coldfire is long only)
Dn         tc,       tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i1s2D6         tc,
1101000100000000    tw,  0000000000000000 tw,

( to address register is long only)
     tc, An          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4D3s1i2S6         tc,
1101000011000000    tw,  0000000000000000 tw,




INSTRUCTION ADDX  001 tc, 00 tc,
Dn         tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4D3i1s2i3S3       tc,
1101000100000000   tw,  0000000000000000 tw,


INSTRUCTION AND 0011 tc, 00 tc,
<#>        tc, Dn      tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i8s2D6+#           tc,
0000001000000000   tw,  0000000000000000 tw,
Dn         tc,       tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i1s2D6         tc,
1100000100000000   tw,  0000000000000000 tw,
     tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4D3i1s2S6         tc,
1100000000000000   tw,  0000000000000000 tw,


INSTRUCTION ASL 010 tc, 00 tc,
<#>       tc, Dn          tc,  null tc, null tc, null tc, N__L #=1>8 + tc,
#all_68000 #all_coldfire +                 tc,      i4#3i1s2D6         tc,
1110000100000000   tw,  0000000000000000 tw,
Dn        tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i1s2i3D3       tc,
1110000100100000   tw,  0000000000000000 tw,


INSTRUCTION ASR 0010 tc, 00 tc,
<#>        tc, Dn          tc,  null tc, null tc, null tc, N__L #=1>8 + tc,
#all_68000 #all_coldfire +                 tc,      i4#3i1s2D6         tc,
1110000000000000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i1s2i3D3       tc,
1110000000100000   tw,  0000000000000000 tw,


( coldfire same as 68k)
INSTRUCTION BCC  010 tc, 00 tc,
     tc, null        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,       a_BCC             tc,
0110000000000000   tw,  0000000000000000 tw,
       tc,       tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,       b_BCC             tc,
0110000000000000   tw,  0000000000000000 tw,

( coldfire same as 68k)
INSTRUCTION BCHG  100 tc, 00 tc,
<#>        tc, Dn          tc,  null tc, null tc, null tc, N__L #=u5 + tc,
#all_68000 #all_coldfire +                           tc,      i10D6+#16          tc,
0000100001000000   tw,  0000000000000000 tw,
<#>        tc,       tc,  null tc, null tc, null tc, NB__ #=u3 + tc,
#all_68000 #all_coldfire +                           tc,      i10D6+#16          tc,
0000100001000000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i4S3i3D6           tc,
0000000101000000   tw,  0000000000000000 tw,
Dn         tc,       tc,  null tc, null tc, null tc, NB__        tc,
#all_68000 #all_coldfire +                           tc,      i4S3i3D6           tc,
0000000101000000   tw,  0000000000000000 tw,


INSTRUCTION BCLR  100 tc, 00 tc,
<#>        tc, Dn          tc,  null tc, null tc, null tc, N__L #=u5 + tc,
#all_68000 #all_coldfire  +                tc,      i10D6+#16          tc,
0000100010000000   tw,  0000000000000000 tw,
<#>        tc,       tc,  null tc, null tc, null tc, NB__ #=u3 + tc,
#all_68000 #all_coldfire +                 tc,      i10D6+#16          tc,
0000100010000000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i3D6           tc,
0000000110000000   tw,  0000000000000000 tw,
Dn         tc,       tc,  null tc, null tc, null tc, NB__        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i3D6           tc,
0000000110000000   tw,  0000000000000000 tw,


INSTRUCTION BKPT 1 tc, 00 tc,
<#>        tc, null        tc,  null tc, null tc, null tc, N___ #=u3 + tc,
#68040 #CPU32 + #5300 + #5400 + tc,   i13#3      tc,
0100100001001000   tw,  0000000000000000 tw,

( address limitations are looked after by the code that generates the relative address)
INSTRUCTION BRA  010 tc, 00 tc,
null       tc, null        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,      a_BRANCH           tc,
0110000000000000   tw,  0000000000000000 tw,
       tc, null        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,      b_BRANCH           tc,
0110000000000000   tw,  0000000000000000 tw,


INSTRUCTION BSET  100 tc, 00 tc,
<#>        tc, Dn          tc,  null tc, null tc, null tc, N__L #=u5 + tc,
#all_68000 #all_coldfire +                 tc,       i10D6+#16         tc,
0000100011000000   tw,  0000000000000000 tw,
<#>        tc,       tc,  null tc, null tc, null tc, NB__ #=u3 + tc,
#all_68000 #all_coldfire +                 tc,      i10D6+#16          tc,
0000100011000000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i3D6           tc,
0000000111000000   tw,  0000000000000000 tw,
Dn         tc,       tc,  null tc, null tc, null tc, NB__        tc,
#all_68000 #all_coldfire +                 tc,      i4S3i3D6           tc,
0000000111000000   tw,  0000000000000000 tw,


( coldfire same as 68000, addressing offset looks after reduced range)
INSTRUCTION BSR  010 tc, 00 tc,
null       tc, null        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,      a_BRANCH           tc,
0110000100000000   tw,  0000000000000000 tw,
       tc, null        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,      b_BRANCH           tc,
0110000100000000   tw,  0000000000000000 tw,


INSTRUCTION BTST  100 tc, 00 tc,
<#>        tc, Dn          tc,  null tc, null tc, null tc, N__L #=u5 + tc,
#all_68000 #all_coldfire +                           tc,       i10D6+#16         tc,
0000100000000000   tw,  0000000000000000 tw,
<#>        tc,       tc,  null tc, null tc, null tc, NB__ #=u3 + tc,
#all_68000 #all_coldfire +                           tc,      i10D6+#16          tc,
0000100000000000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i4S3i3D6           tc,
0000000100000000   tw,  0000000000000000 tw,
Dn         tc,       tc,  null tc, null tc, null tc, NB__        tc,
#all_68000 #all_coldfire +                           tc,      i4S3i3D6           tc,
0000000100000000   tw,  0000000000000000 tw,


INSTRUCTION CHK   001 tc, 00 tc,
     tc, Dn          tc,  null tc, null tc, null tc, __W_         tc,
#all_68000                                 tc,       i4D3i3S6           tc,
0100000110000000   tw,  0000000000000000 tw,



( Coldfire same as 68000)
INSTRUCTION CLR 011 tc, 00 tc,
Dn         tc, null        tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,       i4S3i9            tc,
0111000000000000   tw,  0000000000000000 tw, ( 0 # Dn MOV)
     tc, null        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,       i8s2S6            tc,
0100001000000000   tw,  0000000000000000 tw,
An         tc, null        tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,       i4S3i6S3        tc,
1001000111001000   tw,  0000000000000000 tw, ( An An SUB )

INSTRUCTION CMP  1000 tc, 00 tc,
( 0 #  CMP ->  TST )
<#>        tc,       tc,  null tc, null tc, null tc, NBWL #=0 +  tc,
#all_68000 #all_coldfire +  tc,          i8s2D6         tc,
0100101000000000    tw,  0000000000000000 tw,
( 0 # A0 CMP -> A0 TST for #all_coldfire)
\ bug fix version 2.3; now only allows long word for #5307
<#>        tc, An          tc,  null tc, null tc, null tc, N__L #=0 +  tc,
#68040 #CPU32 #all_coldfire +   + tc,        i8s2D6         tc,
0100101000000000    tw,  0000000000000000 tw,
<#>        tc, Dn     tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,          i8s2D6+#       tc,
0000110000000000    tw,  0000000000000000 tw,
<#>        tc, Dn     tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #5400 +                           tc,          i8s2D6+#       tc,
0000110000000000    tw,  0000000000000000 tw,
     tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,          i4D3i1s2S6     tc,
1011000000000000    tw,  0000000000000000 tw,
     tc, An          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,          i4D3s1i2S6     tc,
1011000011000000    tw,  0000000000000000 tw,
\ 5407 has more options.
     tc, Dn          tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #5400 +                           tc,          i4D3i1s2S6     tc,
1011000000000000    tw,  0000000000000000 tw,
     tc, An          tc,  null tc, null tc, null tc, N_WL        tc,
#all_68000 #5400 +                           tc,          i4D3s1i2S6     tc,
1011000011000000    tw,  0000000000000000 tw,


INSTRUCTION CPUSHL 0001 tc, 00 tc,
 tc, An tc, null tc, null tc, null tc, N___ tc, 
#all_coldfire tc,  i8S2i3D3 tc,
1111010000101000 tw, 0000000000000000 tw,


\ No size modifier is now 32 bit as per rest of instruction set.
INSTRUCTION DIVS  010 tc, 00 tc,
      tc, Dn         tc,  null tc, null tc, null tc, __W_ #=n16 + tc,
#all_68000 #5300 + #5400 +  tc,      W.i4D3i3S6          tc,
1000000111000000    tw,  0000000000000000 tw,

\ #### manual was not consistant may need more work
      tc, Dn         tc,  null tc, null tc, null tc, N__L         tc,
#68040 #5300 + #5400 + #CPU32 +                         tc,    i10S6+i1D3i9D3      tc,
0100110001000000    tw,  0000100000000000 tw,

\ note the second source and destination must be different.
INSTRUCTION REMS 001 tc, 00 tc, 
      tc,  Dn            tc, Dn      tc,  null tc, null tc, N__L         tc,
#68040 #5300 + #5400 + #CPU32  +                        tc,   i10S6+i1F3i9D3      tc,
0100110001000000    tw,  0000100000000000 tw,

INSTRUCTION DIVU  010 tc, 00 tc,
      tc, Dn         tc,  null tc, null tc, null tc, __W_ #=u16 + tc,
#all_68000 #5300 + #5400 +    tc, W.i4D3i3S6           tc,
1000000011000000    tw,  0000000000000000 tw,

\ #### manual was not consistant may need more work
      tc, Dn         tc,  null tc, null tc, null tc, N__L         tc,
#68040 #5300 + #5400 + #CPU32 +                          tc,    i10S6+i1D3i9D3      tc,
0100110001000000    tw,  0000000000000000 tw,

\ note the second source and destination must be different.
INSTRUCTION REMU 001 tc, 00 tc,
      tc, Dn         tc, Dn          tc,  null tc, null tc, N__L         tc,
#68040 #5300 + #5400 + #CPU32 +                  tc,   i10S6+i1F3i9D3      tc,
0100110001000000    tw,  0000000000000000 tw,


INSTRUCTION EOR  010 tc, 00 tc,

<#>         tc, Dn     tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                 tc,     i8s2D6+#            tc,
0000101000000000    tw,  0000000000000000 tw,
Dn          tc,      tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,     i4S3i1s2D6          tc,
1011000100000000    tw,  0000000000000000 tw,


INSTRUCTION EXT  010 tc, 00 tc,
Dn          tc, null       tc,  null tc, null tc, null tc, __W_        tc,
#all_68000 #all_coldfire +                           tc,     i13S3               tc,
0100100010000000    tw,  0000000000000000 tw,
Dn          tc, null       tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,     i13S3               tc,
0100100011000000    tw,  0000000000000000 tw,

INSTRUCTION EXTB  010 tc, 00 tc,
Dn          tc, null       tc,  null tc, null tc, null tc, N__L        tc,
#68040  #CPU32 #all_coldfire +  + tc,     i13S3            tc,
0100100111000000    tw,  0000000000000000 tw,
Dn          tc, null       tc,  null tc, null tc, null tc, __W_        tc,
#all_68000 #all_coldfire +                           tc,     i13S3               tc,
0100100010000000    tw,  0000000000000000 tw,

INSTRUCTION EXTW  001 tc, 00 tc,
Dn          tc, null       tc,  null tc, null tc, null tc, N__L       tc,
#all_68000 #all_coldfire +                           tc,     i13S3               tc,
0100100011000000    tw,  0000000000000000 tw,

INSTRUCTION HALT  001 tc, 00 tc,
null        tc, null       tc,  null tc, null tc, null tc, N___        tc,
#all_coldfire                            tc,     i16                 tc,
0100101011001000    tw,  0000000000000000 tw,

\ #### I think his exists for the 5300
INSTRUCTION ILLEGAL  001 tc, 00 tc,
null        tc, null       tc,  null tc, null tc, null tc, N___        tc,
#all_68000                            tc,     i16                 tc,
0100101011111100    tw,  0000000000000000 tw,


INSTRUCTION INTOUCH 001 tc, 00 tc,
An          tc, null      tc,  null tc, null tc, null tc, N___  tc,
#5400                           tc,      i13S3            tc,
1111010000101000    tw,  0000000000000000 tw,


INSTRUCTION JMP  001 tc, 00 tc,
      tc, null       tc,  null tc, null tc, null tc, N___        tc,
#all_68000 #all_coldfire +                           tc,     i10S6               tc,
0100111011000000    tw,  0000000000000000 tw,

INSTRUCTION JSR  010 tc, 00 tc,
      tc, null       tc,  null tc, null tc, null tc, N___        tc,
#all_68000 #all_coldfire +                           tc,     i10S6               tc,
0100111010000000    tw,  0000000000000000 tw,
\ needed to force the AB address of a JSR into 4 bytes so it can 
\ be altered by  DOES> and code;
      tc, null       tc,  null tc, null tc, null tc, ___L        tc,
#all_68000 #all_coldfire +                           tc,     L.i10S6               tc,
0100111010000000    tw,  0000000000000000 tw,


INSTRUCTION LEA  001 tc, 00 tc,
      tc, An       tc,  null tc, null tc, null tc, N__L          tc,
#all_68000 #all_coldfire +                           tc,     i4D3i3S6            tc,
0100000111000000    tw,  0000000000000000 tw,

INSTRUCTION LINK  001 tc, 00 tc,
An       tc, <#>         tc,  null tc, null tc, null tc,  N_W_ #=n16 + tc,
#all_68000 #all_coldfire +                           tc,     i13S3+#16           tc,
0100111001010000    tw,  0000000000000000 tw,


INSTRUCTION LSL  010 tc, 00 tc,

<#>      tc, Dn          tc,  null tc, null tc, null tc,  N__L #=1>8 + tc,
#all_68000 #all_coldfire +                           tc,     i4#3i1s2i3D3        tc,
1110000100001000    tw,  0000000000000000 tw,
Dn       tc, Dn           tc,  null tc, null tc, null tc, N__L         tc,
#all_68000 #all_coldfire +                           tc,     i4S3i1s2i3D3        tc,
1110000100101000    tw,  0000000000000000 tw,


INSTRUCTION LSR  010 tc, 00 tc,
<#>      tc, Dn          tc,  null tc, null tc, null tc,  N__L #=1>8 + tc,
#all_68000 #all_coldfire +                           tc,     i4#3i1s2i3D3        tc,
1110000000001000    tw,  0000000000000000 tw,
Dn       tc, Dn           tc,  null tc, null tc, null tc, N__L         tc,
#all_68000 #all_coldfire +                           tc,     i4S3i1s2i3D3        tc,
1110000000101000    tw,  0000000000000000 tw,




INSTRUCTION MOV  100011 tc, 00 tc,
( MOVQ )
<#>      tc, Dn          tc,  null tc, null tc, null tc,  N__L #=n8 +  tc,
#all_68000 #all_coldfire +                           tc,     i4D3i1#8            tc,
0111000000000000    tw,  0000000000000000 tw,  ( # Dn MOVQ)

( CLR )
<#>      tc,           tc,  null tc, null tc, null tc, NBWL #=0 +    tc,
#all_68000 #all_coldfire +                           tc,     i8s2D6              tc,
0100001000000000    tw,  0000000000000000 tw,  (  CLR)

( 0 to an address register An An SUB)
<#>      tc, An              tc,  null tc, null tc, null tc, N__L #=0 +    tc,
#all_68000 #all_coldfire +                           tc,     i4D3s1i5D3          tc,
1001000011001000    tw,  0000000000000000 tw,  ( An An SUB)
( life gets complicated. The coldfire will only compile instructions)
( that are 16,32 or 48 bits long)

( MOV3Q )
\ this really is of limited use.
<#>        tc,       tc, null tc, null tc, null tc, N__L #=-1>7 + tc,
#5400                  tc,      i4#3i3D6n2      tc,
1010000101000000    tw,  0000000000000000 tw,

( MOVE proper coldfire )
( Dn,[An],[An]+,[An-] All possible)
   tc,           tc,  null tc, null tc, null tc, NBWL      tc,
#all_68000 #all_coldfire +                 tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( [n16.An],[n16.PC] -> Dn,[An],[An]+,[An-],[n16.An])
   tc,           tc,  null tc, null tc, null tc, NBWL      tc,
#all_68000 #all_coldfire +                 tc,    i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( [n8.An.In.sc],[n8.PC.In.sc],[n32],[n16],# -> Dn,[An],[An]+,[An-] )
   tc,           tc,  null tc, null tc, null tc, NBWL      tc,
#all_68000 #all_coldfire +                tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
\ 5407 adds byte and word immediate value moves to n16An.
<#>   tc, [n16An]          tc,  null tc, null tc, null tc, _BW_      tc,
#5400                 tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,

( MOVE proper coldfire, to and from address register )
\ 2.3 byte moves to and from address was a mistake in manual nothing more
( Dn,[An],[An]+,[An-] -> An)
   tc, An          tc,  null tc, null tc, null tc, N_WL      tc,
#all_coldfire                                 tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( [n16.An],[n16.PC] -> An)
   tc, An          tc,  null tc, null tc, null tc, N_WL      tc,
#all_68000 #all_coldfire  +                    tc,    i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( [n8.An.In.sc],[n8.PC.In.sc],[n32],[n16],# -> An)
   tc, An          tc,  null tc, null tc, null tc, N_WL      tc,
#all_68000 #all_coldfire +                     tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
An   tc,           tc,  null tc, null tc, null tc, N_WL      tc,
#all_68000 #all_coldfire +                    tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( An -> An)
An   tc, An         tc,  null tc, null tc, null tc, N_WL      tc,
#all_68000 #all_coldfire +                    tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,

( to/from  CCR and SR )
   tc,           tc,  null tc, null tc, null tc, N_W_ #=u8 + tc,
#all_68000 #all_coldfire + tc,     W.i10S6             tc,
0100010011000000    tw,  0000000000000000 tw,
    tc, Dn         tc,  null tc, null tc, null tc, N_W_       tc,
#all_68000 #all_coldfire + tc,      i10D6              tc,
0100001011000000    tw,  0000000000000000 tw,
   tc,            tc,  null tc, null tc, null tc, N_W_ #=u16 + tc,
#all_68000 #all_coldfire +                           tc,     W.i10S6              tc,
0100011011000000    tw,  0000000000000000 tw,
     tc, Dn              tc,  null tc, null tc, null tc, N_W_        tc,
#all_68000 #all_coldfire +                           tc,     i10D6                tc,
0100000011000000    tw,  0000000000000000 tw,


Rc        tc, Rn         tc,  null tc, null tc, null tc,  N__L          tc,
#68040 #CPU32 #all_coldfire +  + tc, i16+D4S12     tc,
0100111001111010 tw,  0000000000000000 tw,
Rn        tc, Rc         tc,  null tc, null tc, null tc, N__L           tc,
#68040  #CPU32 #all_coldfire +  + tc, i16+S4D12     tc,
0100111001111011 tw,  0000000000000000 tw,

( additional modes for 68000) 
   tc,           tc,  null tc, null tc, null tc, NBWL      tc,
#all_68000                                 tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( move from address)
An       tc,           tc,  null tc, null tc, null tc, N_WL      tc,
#all_68000 
                           tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( move to an address)
   tc, An             tc,  null tc, null tc, null tc, N_WL       tc,
#all_68000                 tc,     i2s2D6S6            tc,
0000000000000000    tw,  0000000000000000 tw,
( move to USP, doesn't exist on coldfire ) 
An       tc,           tc,  null tc, null tc, null tc, N__L       tc,
#all_68000                           tc,     i13S3               tc,
0100111001100000    tw,  0000000000000000 tw,
( from USP, doesn't exist on coldifire)
    tc, An            tc,  null tc, null tc, null tc, N__L        tc,
#all_68000                            tc,     i13D3               tc,
0100111001101000    tw,  0000000000000000 tw,
( to/from CCR )
   tc,           tc,  null tc, null tc, null tc, N_W_ #=u8 + tc,
#all_68000                           tc,     W.i10S6             tc,
0100010011000000    tw,  0000000000000000 tw,
    tc,          tc,  null tc, null tc, null tc, N_W_       tc,
#68040 #CPU32 + tc,      i10D6              tc,
0100001011000000    tw,  0000000000000000 tw,
   tc,            tc,  null tc, null tc, null tc, N_W_ #=u16 + tc,
#all_68000                               tc,     W.i10S6              tc,
0100011011000000    tw,  0000000000000000 tw,
     tc,          tc,  null tc, null tc, null tc, N_W_        tc,
#all_68000                            tc,     i10D6                tc,
0100000011000000    tw,  0000000000000000 tw,

   tc,            tc,  null tc, null tc, null tc, N__L  tc,
#5300 #5400 +                               tc,     i10S6              tc,
1010000100000000    tw,  0000000000000000 tw,
     tc, Rn        tc,  null tc, null tc, null tc, N__L        tc,
#5300 #5400 +                            tc,     i12D4                tc,
1010000110000000    tw,  0000000000000000 tw,

   tc,            tc,  null tc, null tc, null tc, N__L  tc,
#5300 #5400 +                               tc,     i10S6              tc,
1010110100000000    tw,  0000000000000000 tw,
     tc, Rn        tc,  null tc, null tc, null tc, N__L        tc,
#5300 #5400 +                            tc,     i12D4                tc,
1010110110000000    tw,  0000000000000000 tw,

   tc,            tc,  null tc, null tc, null tc, N__L  tc,
#5300 #5400 +                               tc,     i10S6              tc,
1010100100000000    tw,  0000000000000000 tw,
     tc, Rn        tc,  null tc, null tc, null tc, N__L        tc,
#5300 #5400 +                            tc,     i12D4                tc,
1010100110000000    tw,  0000000000000000 tw,

   tc,     tc,  null tc, null tc, null tc, N__L  tc,
#5300 #5400 +                               tc,     i16              tc,
1010100111000000    tw,  0000000000000000 tw,


\ ---------------------------------------------------------------
INSTRUCTION MOV16 0101 tc, 00 tc,
[An]+    tc, [An]+       tc,  null tc, null tc, null tc,  N___         tc,
#68040                       tc,     i13S3+i1D3i12         tc,
1111011000100000 tw,  1000000000000000 tw,
      tc, [An]           tc,  null tc, null tc, null tc, N___          tc,
#68040                   tc,        i13D3+AB              tc,
1111011000011000 tw,  0000000000000000 tw,
      tc, [An-]          tc,  null tc, null tc, null tc, N___          tc,
#68040                         tc,  i13D3+AB              tc,
1111011000001000  tw,  0000000000000000 tw,
[An]      tc,            tc,  null tc, null tc, null tc, N___      tc,
#68040                         tc,  i13S3+AB              tc,
1111011000010000  tw,  0000000000000000 tw,
[An]+     tc,            tc,  null tc, null tc, null tc, N___      tc,
#68040                         tc,  i13S3+AB               tc,
1111011000000000  tw,  0000000000000000 tw,

INSTRUCTION MMOV 101 tc, 00 tc,
Rlist     tc,      tc,  null tc, null tc, null tc,  N__L         tc,
#all_68000 #all_coldfire +                                  tc, i9s1D6+#          tc,
0100100010000000 tw,  0000000000000000 tw,
    tc, Rlist      tc,  null tc, null tc, null tc, N__L          tc,
#all_68000 #all_coldfire +                                  tc, i9s1S6+#          tc,
0100110010000000 tw,  0000000000000000 tw,
( register list to be mirrored)
Rlist     tc, [An-]      tc,  null tc, null tc, null tc,  N_WL         tc,
#all_68000                                 tc, 1i9s1D6+#         tc,
0100100010000000 tw,  0000000000000000 tw,
\ the addressing modes of the first two entries are repeated here but no matter.
Rlist     tc,      tc,  null tc, null tc, null tc,  N_WL         tc,
#all_68000                                  tc, i9s1D6+#          tc,
0100100010000000 tw,  0000000000000000 tw,
    tc, Rlist      tc,  null tc, null tc, null tc, N_WL          tc,
#all_68000                                  tc, i9s1S6+#          tc,
0100110010000000 tw,  0000000000000000 tw,

INSTRUCTION MOVS 010 tc, 00 tc,
Rn     tc,         tc,  null tc, null tc, null tc,  NBWL         tc,
#68040 #CPU32   +  tc,  i8s2D6+S4i12 tc,
0000111000000000 tw,  0000100000000000 tw,
 tc, Rn            tc,  null tc, null tc, null tc, NBWL          tc,
#68040  #CPU32   + tc,  i8s2S6+D4i12 tc,
0000111000000000 tw,  0000000000000000 tw,

INSTRUCTION MULS  0100 tc, 00 tc,
      tc, Dn         tc,  null tc, null tc, null tc, N_W_ #=n16 + tc,
#all_68000 #all_coldfire +                           tc,      W.i4D3i3S6         tc,
1100000111000000    tw,  0000000000000000 tw,
      tc, Dn         tc,  null tc, null tc, null tc, ___L        tc,
#68040 #CPU32  + #all_coldfire + tc,    i10S6+i1D3i9D3     tc,
0100110000000000    tw,  0000100000000000 tw,
      tc, Dn         tc,  null tc, null tc, null tc, ___L        tc,
#68040 #CPU32  + tc,    i10S6+i1D3i9D3     tc,
0100110000000000    tw,  0000100000000000 tw,
( 64 bit results in two registers)
      tc,  Dn            tc, Dn      tc,  null tc, null tc,  N__L        tc,
#68040  #CPU32   + tc,   i10S6+i1F3i9D3     tc,
0100110000000000    tw,  0000110000000000 tw,

INSTRUCTION MULU  0100 tc, 00 tc,
      tc, Dn         tc,  null tc, null tc, null tc, N_W_ #=u16 + tc,
#all_68000 #all_coldfire +                           tc,      W.i4D3i3S6         tc,
1100000011000000    tw,  0000000000000000 tw,
      tc, Dn         tc,  null tc, null tc, null tc, ___L        tc,
#68040  #CPU32 #all_coldfire +  + tc,    i10S6+i1D3i9D3     tc,
0100110000000000    tw,  0000000000000000 tw,
      tc, Dn         tc,  null tc, null tc, null tc, ___L        tc,
#68040  #CPU32  + tc,    i10S6+i1D3i9D3     tc,
0100110000000000    tw,  0000000000000000 tw,
( 64 bit result)
      tc, Dn         tc, Dn          tc,  null tc, null tc, N__L        tc,
#68040  #CPU32  + tc,   i10S6+i1F3i9D3     tc,
0100110000000000    tw,  0000010000000000 tw,


INSTRUCTION MVS  01 tc, 00 tc,
      tc, Dn       tc,  null tc, null tc, null tc, _BW_        tc,
#5400                     tc,     i4D3i2s1S6               tc,
0111000100000000    tw,  0000000000000000 tw,


INSTRUCTION MVZ  01 tc, 00 tc,
      tc, Dn       tc,  null tc, null tc, null tc, _BW_        tc,
#5400                     tc,     i4D3i2s1S6               tc,
0111000110000000    tw,  0000000000000000 tw,

INSTRUCTION NBCD  01 tc, 00 tc,
      tc, null       tc,  null tc, null tc, null tc, _B__        tc,
#all_68000                     tc,     i10S6               tc,
0100100000000000    tw,  0000000000000000 tw,

INSTRUCTION NEG  10 tc, 00 tc,
Dn          tc, null       tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire  +                tc,     i8s2S6              tc,

0100010000000000    tw,  0000000000000000 tw,
      tc, null       tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                     tc,     i8s2S6              tc,
0100010000000000    tw,  0000000000000000 tw,

INSTRUCTION NEGX 10 tc, 00 tc,
Dn      tc, null       tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                            tc,    i8s2S6              tc,
0100000000000000    tw,  0000010000000000 tw,

      tc, null       tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                            tc,    i8s2S6              tc,
0100000000000000    tw,  0000010000000000 tw,

INSTRUCTION NOP  01 tc, 00 tc,
null        tc, null       tc,  null tc, null tc, null tc, N___        tc,
#all_68000 #all_coldfire +                           tc,     i16                 tc,
0100111001110001    tw,  0000000000000000 tw,

INSTRUCTION NOT  10 tc, 00 tc,
Dn      tc, null       tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,     i8s2S6              tc,
0100011000000000    tw,  0000000000000000 tw,

      tc, null       tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                           tc,     i8s2S6              tc,
0100011000000000    tw,  0000000000000000 tw,

INSTRUCTION OR  1000 tc, 00 tc,
<#>         tc, Dn     tc,  null tc, null tc, null tc, N__L       tc,
#all_68000 #all_coldfire +                           tc,     i8s2D6+#           tc,
0000000000000000    tw,  0000000000000000 tw,
      tc, Dn        tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,     i4D3i1s2S6         tc,
1000000000000000    tw,  0000000000000000 tw,
Dn          tc,     tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,     i4S3i1s2D6         tc,
1000000100000000    tw,  0000000000000000 tw,

<#>         tc,      tc,  null tc, null tc, null tc, NBWL       tc,
#all_68000                                tc,     i8s2D6+#           tc,
0000000000000000    tw,  0000000000000000 tw,
      tc, Dn        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                                tc,     i4D3i1s2S6         tc,
1000000000000000    tw,  0000000000000000 tw,
Dn          tc,     tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                                tc,     i4S3i1s2D6         tc,
1000000100000000    tw,  0000000000000000 tw,
<#>         tc,      tc,  null tc, null tc, null tc, NB__ #=u8 + tc,
#all_68000                                tc,     i16+#16            tc,
0000000000111100    tw,  0000000000000000 tw,
<#>          tc,      tc,  null tc, null tc, null tc, N_W_ #=u16 + tc,
#all_68000                                tc,     i16+#16            tc,
0000000001111100    tw,  0000000000000000 tw,

INSTRUCTION PEA  01 tc, 00 tc,
     tc, null       tc,  null tc, null tc, null tc, N__L         tc,
#all_68000 #all_coldfire +                           tc,     i10S6               tc,
0100100001000000    tw,  0000000000000000 tw,

INSTRUCTION PTESTW  01 tc, 00 tc,
[An]      tc, null       tc,  null tc, null tc, null tc, N___         tc,
#68040                         tc,     i13S3              tc,
1111010101001000    tw,  0000000000000000 tw,

INSTRUCTION PTESTR  01 tc, 00 tc,
[An]      tc, null       tc,  null tc, null tc, null tc, N___         tc,
#68040                         tc,     i13S3              tc,
1111010101101000    tw,  0000000000000000 tw,


INSTRUCTION PMOV 010 tc, 00 tc,
Dn         tc, [n16An]    tc,  null tc, null tc, null tc,  N_WL         tc,
#all_68000                             tc,  i4S3i2s1i3D3+disp tc,
0000000110001000 tw,  0000000000000000 tw,
[n16An]    tc, Dn         tc,  null tc, null tc, null tc, N_WL          tc,
#all_68000                                tc,  i4D3i2s1i3S3+disp tc,
0000000100001000 tw,  0000000000000000 tw,

INSTRUCTION PULSE  001 tc, 00 tc,
null        tc, null       tc,  null tc, null tc, null tc, N___        tc,
#all_coldfire                           tc,     i16                 tc,
0100101011001100    tw,  0000000000000000 tw,

INSTRUCTION RESET  01 tc, 00 tc,
null       tc, null       tc,  null tc, null tc, null tc, N__L         tc,
#all_68000                          tc,     i16                 tc,
0100111001110000    tw,  0000000000000000 tw,

INSTRUCTION ROL 011 tc, 00 tc,
<#>       tc, Dn          tc,  null tc, null tc, null tc, NBWL #=1>8 + tc,
#all_68000                            tc,      i4#3i1s2D6         tc,
1110000100011000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                            tc,      i4S3i1s2i3D3       tc,
1110000100111000   tw,  0000000000000000 tw,
     tc, null        tc,  null tc, null tc, null tc, __W_        tc,
#all_68000                           tc,      i10S6              tc,
1110011111000000   tw,  0000000000000000 tw,

INSTRUCTION ROR 011 tc, 00 tc,
<#>        tc, Dn          tc,  null tc, null tc, null tc, NBWL #=1>8 + tc,
#all_68000                            tc,      i4#3i1s2D6         tc,
1110000000011000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                            tc,      i4S3i1s2i3D3       tc,
1110000000111000   tw,  0000000000000000 tw,
     tc, null        tc,  null tc, null tc, null tc, __W_        tc,
#all_68000                            tc,      i10S6              tc,
1110011011000000   tw,  0000000000000000 tw,

INSTRUCTION ROXL 011 tc, 00 tc,
<#>       tc, Dn          tc,  null tc, null tc, null tc, NBWL #=1>8 + tc,
#all_68000                          tc,      i4#3i1s2D6         tc,
1110000100010000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                            tc,      i4S3i1s2i3D3       tc,
1110000100110000   tw,  0000000000000000 tw,
     tc, null        tc,  null tc, null tc, null tc, N_W_        tc,
#all_68000                           tc,      i10S6              tc,
1110010111000000   tw,  0000000000000000 tw,

INSTRUCTION ROXR 011 tc, 00 tc,
<#>        tc, Dn          tc,  null tc, null tc, null tc, NBWL #=1>8 + tc,
#all_68000                           tc,      i4#3i1s2D6         tc,
1110000000010000   tw,  0000000000000000 tw,
Dn         tc, Dn          tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                            tc,      i4S3i1s2i3D3       tc,
1110000000110000   tw,  0000000000000000 tw,
     tc, null        tc,  null tc, null tc, null tc, N_W_        tc,
#all_68000                            tc,      i10S6              tc,
1110010011000000   tw,  0000000000000000 tw,

INSTRUCTION RTD 01 tc, 00 tc,
<#>        tc, null        tc,  null tc, null tc, null tc, NBWL #=n16 + tc,
#68040 #CPU32   + tc,  i16+#16    tc,
0100111001110100   tw,  0000000000000000 tw,

INSTRUCTION RTE 01 tc, 00 tc,
null       tc, null        tc,  null tc, null tc, null tc, N___        tc,
#all_68000 #all_coldfire +                                  tc,   i16            tc,
0100111001110011   tw,  0000000000000000 tw,

INSTRUCTION RTR 01 tc, 00 tc,
null       tc, null        tc,  null tc, null tc, null tc, N___        tc,
#all_68000                               tc,   i16            tc,
0100111001110111   tw,  0000000000000000 tw,

INSTRUCTION RTS 01 tc, 00 tc,
null       tc, null        tc,  null tc, null tc, null tc, N___        tc,
#all_68000 #all_coldfire +                                  tc,   i16            tc,
0100111001110101   tw,  0000000000000000 tw,


INSTRUCTION SATS  001 tc, 00 tc,
Dn          tc, null       tc,  null tc, null tc, null tc, N__L       tc,
#5400                           tc,     i13S3               tc,
0100110010000000    tw,  0000000000000000 tw,

INSTRUCTION SCC 10 tc, 00 tc,
Dn     tc,       tc,  null tc, null tc, null tc, NB__        tc,
#all_68000 #all_coldfire +                           tc,      i4C4i2S6           tc,
0101000011000000   tw,  0000000000000000 tw,

     tc,       tc,  null tc, null tc, null tc, NB__        tc,
#all_68000 #all_coldfire +                           tc,      i4C4i2S6           tc,
0101000011000000   tw,  0000000000000000 tw,

INSTRUCTION STOP  001 tc, 00 tc,
<#>          tc, null      tc,  null tc, null tc, null tc, N_W_ #=u16 + tc,
#all_68000 #all_coldfire +                           tc,      i16+#16            tc,
0100111001110010    tw,  0000000000000000 tw,


INSTRUCTION SUB  1010 tc, 00 tc,
<#>         tc,      tc,  null tc, null tc, null tc, N__L #=1>8 + tc,
#all_68000 #all_coldfire +                           tc,      i4#3i1s2D6         tc,
0101000100000000    tw,  0000000000000000 tw, ( #  SUBQ)
<#>         tc, Dn     tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i8s2D6+#           tc,
0000010000000000    tw,  0000000000000000 tw, ( # SUBI)
Dn          tc,      tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i4S3i1s2D6         tc,
1001000100000000    tw,  0000000000000000 tw,
      tc, Dn         tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i4D3i1s2S6         tc,
1001000000000000    tw,  0000000000000000 tw,
An          tc, Dn         tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i4D3i1s2S6         tc,
1001000000000000    tw,  0000000000000000 tw,
      tc, An         tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i4D3s1i2S6         tc,
1001000011000000    tw,  0000000000000000 tw,

<#>         tc,      tc,  null tc, null tc, null tc, NBWL #=1>8 + tc,
#all_68000                          tc,      i4#3i1s2D6         tc,
0101000100000000    tw,  0000000000000000 tw, ( #  SUBQ)
<#>         tc,      tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                           tc,      i8s2D6+#           tc,
0000010000000000    tw,  0000000000000000 tw, ( # SUBI)
Dn          tc,      tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                           tc,      i4S3i1s2D6         tc,
1001000100000000    tw,  0000000000000000 tw,
      tc, Dn         tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                           tc,      i4D3i1s2S6         tc,
1001000000000000    tw,  0000000000000000 tw,
An          tc, Dn         tc,  null tc, null tc, null tc, N_WL        tc,
#all_68000                           tc,      i4D3i1s2S6         tc,
1001000000000000    tw,  0000000000000000 tw,
      tc, An         tc,  null tc, null tc, null tc, N_WL        tc,
#all_68000                           tc,      i4D3s1i2S6         tc,
1001000011000000    tw,  0000000000000000 tw,

INSTRUCTION SUBX  010 tc, 00 tc,

Dn         tc, Dn          tc,  null tc, null tc, null tc, N__L        tc,
#all_68000 #all_coldfire +                           tc,      i4D3i1s2i3S3       tc,
1001000100000000   tw,  0000000000000000 tw,

Dn         tc, Dn          tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                            tc,      i4D3i1s2i3S3       tc,
1001000100000000   tw,  0000000000000000 tw,
[An-]      tc, [An-]       tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000                            tc,      i4D3i1s2i3S3       tc,
1001000100001000    tw,  0000000000000000 tw,

INSTRUCTION SWP  01 tc, 00 tc,
Dn         tc, null        tc,  null tc, null tc, null tc, N_W_        tc,
#all_68000 #all_coldfire +                           tc,      i13S3              tc,
0100100001000000   tw,  0000000000000000 tw,

INSTRUCTION TAS  01 tc, 00 tc,
         tc, null        tc,  null tc, null tc, null tc,  NB__   tc,
#all_68000 #5400 +                    tc,      i10S6              tc,
0100101011000000   tw,  0000000000000000 tw,

INSTRUCTION TRAP  01 tc, 00 tc,
<#>         tc, null        tc,  null tc, null tc, null tc,   NB__ #=u4 + tc,
#all_68000 #all_coldfire +                           tc,      i12#4              tc,
0100111001000000   tw,  0000000000000000 tw,
.S .( after TRAP)

INSTRUCTION TRAPCC  011 tc, 00 tc,
<#>         tc,       tc,  null tc, null tc, null tc, __W_ #=16b  + tc,
#68040 #CPU32   + tc,   i4C4i8+#           tc,
0101000011111010   tw,  0000000000000000 tw,
<#>         tc,       tc,  null tc, null tc, null tc, N__L          tc,
#68040  #CPU32  + tc,    i4C4i8+#           tc,
0101000011111011   tw,  0000000000000000 tw,
      tc, null        tc,  null tc, null tc, null tc, N___          tc,
#68040 #CPU32   + tc,    i4C4i8             tc,
0101000011111100   tw,  0000000000000000 tw,

\ coldfire specific, not really of much use
INSTRUCTION TRAPFF  011 tc, 00 tc,
<#>         tc, null      tc,  null tc, null tc, null tc, __W_ #=16b  + tc,
#all_coldfire tc,   i16+#16           tc,
0101000111111010   tw,  0000000000000000 tw,
<#>         tc, null      tc,  null tc, null tc, null tc, N__L          tc,
#all_coldfire tc,    i16+#32           tc,
0101000111111011   tw,  0000000000000000 tw,
      tc, null        tc,  null tc, null tc, null tc, N___          tc,
#all_coldfire    tc,    i16             tc,
0101000111111100   tw,  0000000000000000 tw,

INSTRUCTION TRAPV  01 tc, 00 tc,
null        tc, null        tc,  null tc, null tc, null tc, N___        tc,
#all_68000                          tc,      i16                tc,
0100111001110110 tw,  0000000000000000 tw,

INSTRUCTION TST  010 tc, 00 tc,
      tc, null        tc,  null tc, null tc, null tc, NBWL        tc,
#all_68000 #all_coldfire +                           tc,      i8s2S6             tc,
0100101000000000 tw,  0000000000000000 tw,
An          tc, null        tc,  null tc, null tc, null tc, N_WL        tc,
#68040  #CPU32 + #5300 + #5400  + tc,    i8s2S6             tc,
0100101000000000 tw,  0000000000000000 tw,

INSTRUCTION UNLK  01 tc, 00 tc,
An          tc, null        tc, null tc, null tc, null tc, N___        tc,
#all_68000 #all_coldfire +                           tc,      i13S3              tc,
0100111001011000 tw,  0000000000000000 tw,


INSTRUCTION BGND 01 tc, 00 tc,
null       tc, null        tc,  null tc, null tc, null tc, N___        tc,
#CPU32                          tc,      i16                tc,
0100101011111010   tw,  0000000000000000 tw,


\ new coldfire instructions
INSTRUCTION MAC 01 tc, 00 tc,
Rn tc, Rn tc, null tc, null tc, null tc, N_WL tc,
#5300 #5400 + tc, mac tc,
1010000000000000   tw,  0000000000000000 tw,

INSTRUCTION MACL 01 tc, 00 tc,
Rn tc, Rn tc,  tc, Rn tc, null tc, N_WL tc, 
#5300 #5400 + tc, macl tc,
1010000010000000   tw, 0000000000000000 tw,

INSTRUCTION MSAC 01 tc, 00 tc, 
Rn tc, Rn tc, null tc, null tc, null tc, N_WL tc,
#5300 #5400 + tc, mac tc,
1010000000000000   tw,  0000000100000000 tw,

INSTRUCTION MSACL 01 tc, 00 tc,
Rn tc, Rn tc,  tc, Rn tc, null tc, N_WL tc, 
#5300 #5400 + tc, macl tc,
1010000010000000   tw,  0000000100000000 tw,



	( define the registers) HEX
	#all_68000 #all_coldfire + #cpu_reg #data +   00 + REGISTER D0
	#all_68000 #all_coldfire + #cpu_reg #data +   01 + REGISTER D1
	#all_68000 #all_coldfire + #cpu_reg #data +   02 + REGISTER D2
	#all_68000 #all_coldfire + #cpu_reg #data +   03 + REGISTER D3
	#all_68000 #all_coldfire + #cpu_reg #data +   04 + REGISTER D4
	#all_68000 #all_coldfire + #cpu_reg #data +   05 + REGISTER D5
	#all_68000 #all_coldfire + #cpu_reg #data +   06 + REGISTER D6
	#all_68000 #all_coldfire + #cpu_reg #data +   07 + REGISTER D7
	#all_68000 #all_coldfire + #cpu_reg #addr +  00 + REGISTER A0
	#all_68000 #all_coldfire + #cpu_reg #addr +  01 + REGISTER A1
	#all_68000 #all_coldfire + #cpu_reg #addr +  02 + REGISTER A2
	#all_68000 #all_coldfire + #cpu_reg #addr +  02 + REGISTER OP
	#all_68000 #all_coldfire + #cpu_reg #addr +  03 + REGISTER A3
	#all_68000 #all_coldfire + #cpu_reg #addr +  03 + REGISTER U
	#all_68000 #all_coldfire + #cpu_reg #addr +  04 + REGISTER A4
	#all_68000 #all_coldfire + #cpu_reg #addr +  04 + REGISTER W
	#all_68000 #all_coldfire + #cpu_reg #addr +  05 + REGISTER A5
	#all_68000 #all_coldfire + #cpu_reg #addr +  05 + REGISTER LP		
	#all_68000 #all_coldfire + #cpu_reg #addr +  06 + REGISTER A6
	#all_68000 #all_coldfire + #cpu_reg #addr +  06 + REGISTER S
	#all_68000 #all_coldfire + #cpu_reg #addr +  07 + REGISTER A7
	#all_68000 #all_coldfire + #cpu_reg #addr +  07 + REGISTER R


	( conditional codes) HEX
	#all_68000 #all_coldfire + #flag   00  +   REGISTER  TR
	#all_68000 #all_coldfire + #flag   01  +   REGISTER  FS   ( Not available for Bcc)
	#all_68000 #all_coldfire + #flag   02  +   REGISTER  HI
	#all_68000 #all_coldfire + #flag   03  +   REGISTER  LS
	#all_68000 #all_coldfire + #flag   04  +   REGISTER  CC
	#all_68000 #all_coldfire + #flag   05  +   REGISTER  CS
	#all_68000 #all_coldfire + #flag   06  +   REGISTER  NE
	#all_68000 #all_coldfire + #flag   07  +   REGISTER  EQ
	#all_68000 #all_coldfire + #flag   08  +   REGISTER  VC
	#all_68000 #all_coldfire + #flag   09  +   REGISTER  VS
	#all_68000 #all_coldfire + #flag   0A  +   REGISTER  PL
	#all_68000 #all_coldfire + #flag   0B  +   REGISTER  MI
	#all_68000 #all_coldfire + #flag   0C  +   REGISTER  GE
	#all_68000 #all_coldfire + #flag   0D  +   REGISTER  LT
	#all_68000 #all_coldfire + #flag   0E  +   REGISTER  GT
	#all_68000 #all_coldfire + #flag   0F  +   REGISTER  LE


	( special REGISTER s) HEX
	#all_68000 #all_coldfire + #special_reg #PC        + REGISTER  PC
	#all_68000 #all_coldfire + #special_reg #CCR       + REGISTER  CCR
	#all_68000 #all_coldfire + #special_reg #SR        + REGISTER  SR
	#all_68000 #all_coldfire + #special_reg #ACC       + REGISTER  ACC
	#all_68000 #all_coldfire + #special_reg #MASK      + REGISTER  MASK
	#all_68000 #all_coldfire + #special_reg #MACSR     + REGISTER  MACSR


	( control REGISTER )  HEX
	( Missing code generates an illegal instruction exception)
	#68040  #CPU32  + #control_reg 000 +
	REGISTER     SFC     ( source function code)
	\ ##### remove #5300 + #5400 +
	#68040  #CPU32 + #5300 + #5400 + #control_reg 001 +
	REGISTER     DFC     ( Destination function code)


	#5300 #5400 +    #control_reg 002 +
	REGISTER     CACR     ( )

	#5300 #5400 +    #control_reg 004 +
	REGISTER     ACR0     ( Access control register 0)

	#5300 #5400 +    #control_reg 005 +
	REGISTER     ACR1     ( Access control register 1)

	#5400    #control_reg 006 +
	REGISTER     ACR2     ( Access control register 3)

	#5400    #control_reg 007 +
	REGISTER     ACR3     ( Access control register 4)

	#all_68000 #all_coldfire +  #control_reg 800 +
	REGISTER     USP     ( User stack pointer)

	#68040 #CPU32 + #5300 + #5400 + #control_reg 801 +
	REGISTER     VBR     ( Vector base REGISTER )


	#5300 #control_reg C04 +
	REGISTER     RAMBAR   ( Ram base address register)
	#5300 #5400 +    #control_reg C0F +
	REGISTER     MBAR     ( Module base address register)


	#5400    #control_reg C04 +
	REGISTER     RAMBAR0   ( Ram base address register)

	#5400    #control_reg C05 +
	REGISTER     RAMBAR1   ( Ram base address register)
		
	( special REGISTERs)  HEX
	#5400  #cache      01         + REGISTER DC ( Data)
	#5400  #cache      02         + REGISTER IC ( instruction)
	#5300  #5400 + #cache      03         + REGISTER BC ( Both cache )
	#5400  #cache      00         + REGISTER NC ( No caches)


	( W. L. B. )  HEX
	#byte SIZE B.
	#word SIZE W.
	#long SIZE L.


	#flags>> _flags >>
	#flags<< _flags << 
	#flags&  _flags &
	#flagsU. _flags U.


	#_]+    TERMINATOR  ]+
	#_-]    TERMINATOR  -]
	#_]     TERMINATOR  ]
	#_}     TERMINATOR  |]

	#_]+    OLD_TERMINATOR )+
	#_-]    OLD_TERMINATOR -)
	#_]     OLD_TERMINATOR )



	: [ ( --)
		1 %indirection +!
		%indirection @ #indirection < not ABORT" Too many [ "
		@s %ind_stack %indirection @ 4* + !
	;


	: \\
		%indirection @ #ef_fieldASL LSHIFT
		%field @ #num_fields < not IF
			to_many_fields 
		THEN
		%field @ #ef_fieldASL LSHIFT +
		%ef_table +
		\ addr (--
		DUP #_mode + C@ not IF
			\ addr (--
			#_\\ SWAP #_mode + C!
			EXIT
		THEN
		\ addr (--
		DUP #_mode + C@ #_\\ <> ABORT" Mixed mode"
		( addr (--)
		#_reg OVER + W@
		( addr reg(--)
		OVER #_index + W@ not IF
			2DUP SWAP #_index + W!
		THEN
		OVER #_index + W@
		( addr reg1 reg2(--)
		#set® forth_and
		SWAP #set® forth_and
		2DUP < IF
			SWAP
		THEN
		( addr large small(--)
		SWAP 1+ SWAP
		DO  ( addr(--)
			DUP #_displacement + @
			I 2** forth_or
			OVER #_displacement + !
		LOOP
		0 OVER #_reg + W!
		0 OVER #_index + W!
		DROP
		1 %field +!
	;





	: +XL ( --)
		%indirection @ ABORT" Old and new syntax may not be used together"
		%field @ not ABORT" No register supplied"
		%field @ 1 - #ef_fieldASL LSHIFT
		%ef_table +
		\ from(--
		DUP DUP #ef_entry_length +  
		\ from from to (--
		#ef_entry_length MOVE
		\ from(--
		DUP #_address_data ERASE
		\ from(--
		#ef_entry_length +
		\ to(--
		DUP #_reg + W@ OVER #_index + W!
		0 OVER #_reg + W!
		\ pfa_value from(--
		#long SWAP #_size + C!
	;


	: \ ( --)
		%indirection @ #ef_entryASL LSHIFT
		%field @ #num_fields < not ABORT" Too many fields"
		%field @ #ef_fieldASL LSHIFT
		+ %ef_table +
		( addr (--)
		#_mode OVER + C@ not IF 
			( a comment)
			DROP
			#TIB @ >IN !
			EXIT
		THEN
		( addr (--)
		#_mode OVER + C@ #_\\ <> ABORT" Mixed addressing mode"
		( addr (--)
		#_reg OVER + W@
		( addr reg(--)
		OVER #_index + W@ not IF
			2DUP SWAP #_index + W!
		THEN
		OVER #_index + W@
		( addr reg1 reg2(--)
		#set® forth_and
		SWAP #set® forth_and
		2DUP < IF
			SWAP
		THEN
		( addr large small(--)
		SWAP 1+ SWAP
		DO  ( addr(--)
			DUP #_displacement + @
			I 2** forth_or
			OVER #_displacement + !
		LOOP
		0 OVER #_reg + W!
		0 OVER #_index + W!
		DROP
	;


	: AB ( addr --)
		%field @ #ef_fieldASL LSHIFT
		%ef_table +
		#ef_entry_length +
		#_] OVER #_mode + C!
		#_displacement + !
		1 %field +!
	;


	( standard macros, no checking that conditionals match ) HEX

	: IF compliment_condition ahere
		DUP BCC  ;

	: UNTIL compliment_condition BCC ;

	: THEN ( addr --) compile_branch  ;

	: ELSE FS IF SWAP THEN ;

	: BEGIN ahere   ;

	: WHILE IF  ;

	: REPEAT  >R  BRA  R> THEN ;

	\ so we pick up the forth versions of IF THEN
	target_also FORTH

	: NEXT
		( word exit code)
		 _%local_use @ IF
			_%local_output_bytes @ IF
				_%local_output_bytes @ 4 / 
				7000 OR 		
					 XW,
				204D XW,                               
													  
				2D20 XW,                               
				5380 XW,                               
				66FA XW,								  
			THEN
			4E5D XW,    
			PREVIOUS  ( get rid of &local)
			_end_local_dictionary                         
		THEN  
		4E75 XW,  
		!code
		INIT_ASSEMBLER  
		PREVIOUS
	;	

	\ same as NEXT but doesn't change vocabulary order.
	\ This version has same effective action as the FORTH EXIT.
	\ That is it leaves the current definition.
	: EXIT
		( word exit code)
		_%local_use @ IF
			_%local_output_bytes @ IF
				_%local_output_bytes @ 4 / 
				7000 OR 		
					 XW,
				204D XW,                               
													  
				2D20 XW,                               
				5380 XW,                               
				66FA XW,								  
			THEN
				4E5D XW,                              
		THEN  
		4E75 XW,    
	;	

	target_previous
	assembler



	( the words that were used for indirect with displacment)  HEX
	#cpu_reg #addr + 00 + OLD_DISPLACEMENT 0)
	#cpu_reg #addr + 01 + OLD_DISPLACEMENT 1)
	#cpu_reg #addr + 02 + OLD_DISPLACEMENT 2)
	#cpu_reg #addr + 03 + OLD_DISPLACEMENT 3)
	#cpu_reg #addr + 04 + OLD_DISPLACEMENT W)
	#cpu_reg #addr + 05 + OLD_DISPLACEMENT LP)
	#cpu_reg #addr + 06 + OLD_DISPLACEMENT S)
	#cpu_reg #addr + 07 + OLD_DISPLACEMENT R)
	#special_reg #PC    + OLD_DISPLACEMENT PC)




	: U)   user_base - 3) ;

	' INIT_ASSEMBLER 'init_assembler t!

#5307 [IF] 
	 : assembler>dictionary ( --)
		['] HERE 'ahere !
		['] W!   'aw!   !
		['] W@   'aw@   !
		['] ALLOT  'agap  !
		#5300 %cpu !
	;
[THEN]


#5407 [IF] 
	 : assembler>dictionary ( --)
		['] HERE 'ahere !
		['] W!   'aw!   !
		['] W@   'aw@   !
		['] ALLOT  'agap  !
		#5400 %cpu !
	;
[THEN]
	' assembler>dictionary (assembler>dict) t!



	HOST DEFINITIONS
	target_previous
	target_previous_definitions

	assembler DEFINITIONS

	forth : EXCEPTION ( a n--) 
		assembler  
		SWAP # D0 MOV 
		D0 4* _interrupt_vectors +  AB MOV 
	;

	HOST      DEFINITIONS

	: @exception ( n -- addr )
		4* _interrupt_vectors + @ 
	;
./version081/bank.html0100777000000000000000000002634007300314345013444 0ustar rootroot COLDFORTH KERNEL

bank file operations

license

Get data from the memory between CPU I and II. CPU I is requester CPU II provides the data, 

 
: claim_bank ( --)
	BEGIN	
		BEGIN
			_#cpu_II_bank3_claim C@ 01 AND not 
		UNTIL
		TRUE _#cpu_I_bank3_claim C!
		_#cpu_II_bank3_claim C@ 01 AND not IF
			TRUE _#bank3_direction C!
			EXIT
		THEN
		FALSE _#cpu_I_bank3_claim C!
	AGAIN
;

: release_bank ( --)
		FALSE _#cpu_I_bank3_claim C!
;


ram_create %bank_file_facility #facility_length  ram_allot

: interrupt_cpuii_for_file
	_lock_word
	claim_bank
	TRUE %bank_i_file !
	release_bank
	_unlock_word
	TRUE _#interrupt_other_cpu C!
;

\ ### what should this do.
: reset_ii_interrupt
	TRUE _#interrupt_other_cpu_reset C!	
;


ram_variable %bank_interrupt
interrupt:  bank_interrupt
	1 %bank_interrupt +!
	reset_ii_interrupt
	claim_bank
	%bank_ii_file @ IF
		zero %bank_ii_file !
		%bank_file_facility _#facility + @ ?DUP IF
			wake SWAP W!
		THEN
	THEN
	%bank_ii_terminal @ IF
		%bank_ii_unit @ IF
			%bank_ii_unit @ #p_status + @ IF
				wake %bank_ii_unit @ #p_status + @ W!
			THEN
			zero %bank_ii_unit !
		THEN
		zero %bank_ii_terminal !
	THEN
	%bank_ii_^ced @ IF
		%bank_ii_unit @ IF
			%bank_ii_unit @ #p_^C_task + @ IF
				TRUE %bank_ii_unit @ #p_^C_task + @ ^c_set user_base - +  W!
			THEN
			zero %bank_ii_unit !
		THEN
		zero %bank_ii_terminal !
	THEN				
	release_bank
;interrupt	


: rti_check_error { -- }
	_lock_word
	claim_bank
	%bank_file_table #flbus_count + W@ IF
		\ a word operation will work against the dual port
		\ memory.
		%bank_buffer W@ $FF00 AND [ #error_ilan 8 LSHIFT ]T LITERAL  = IF
			\ move the data into a buffer
			%bank_file_table #flbus_count + W@ 3 + -4 AND 
			release_bank 
			_unlock_word
			
			DUP get_buffer

			_lock_word
			claim_bank
			%bank_buffer buffer ROT MOVE
			release_bank
			_unlock_word
			buffer 1+ $error #$buffer $move
			kill_buffer
			$error $ABORT
		THEN
	THEN
	release_bank
	_unlock_word
;


( flag is true if fault)
: perform_bank_op ( addr count -- )
	TUCK 3+ -4 AND
	_lock_word 
	claim_bank
		%bank_buffer SWAP MOVE
		\ count(--
		( pointer to table)
		%bank_file_table %bank_(file_table) !
		%bank_buffer %bank_file_table #flbus_buffer + !
		%bank_file_table #flbus_count + W!
	release_bank
	_unlock_word
	xtest
	interrupt_cpuii_for_file
	#2sec 2* xwait
	xtimeout? IF
		TRUE ABORT" Master didn't process file request"
	THEN
	rti_check_error 
;



: close_bank ( file_code --)
	%bank_file_facility get
	[ #ilan_close_header_length 3+ -4 AND ]T LITERAL  get_buffer  
	#close_ilan #ilan_disk_code buffer + C!
	#ilan_disk_i/o_id buffer  + unaligned!
	buffer [ #ilan_close_header_length 3+ -4 AND ]T LITERAL 
	['] perform_bank_op CATCH
	?DUP IF
		kill_buffer
		%bank_file_facility release
		$ABORT
	THEN
	kill_buffer 
	%bank_file_facility release
;


#$count_length 1 ??=

: open_bank ( add n mode file_code --)
	%bank_file_facility get
	jump [ #$count_length #ilan_open_header_length + ]T LITERAL + get_buffer 
	#open_ilan #ilan_disk_code buffer + C!
	#ilan_disk_i/o_id buffer + unaligned!
	#ilan_disk_mode buffer + unaligned!
	\ add n(--
	TUCK
	\ ###
	\ convenient to use $make here but isn't correct.
	\ The string structure is set by a protocol structure not by
	\ the FORTH spec. If the structure of $ changes this will be wrong
	buffer #ilan_open_header_length + $make
	\ length(--
	buffer SWAP #ilan_open_header_length + #$count_length +
	['] perform_bank_op CATCH
	?DUP IF
		kill_buffer
		%bank_file_facility release
		$ABORT
	THEN 
	kill_buffer
	%bank_file_facility release
;

: read_bank ( addr n seek_pointer file_code -- n )

	%bank_file_facility get

	#ilan_disk_header_length get_buffer

	4dup
	#read_ilan #ilan_disk_code buffer  + C!
	#ilan_disk_i/o_id buffer  + unaligned!
	#ilan_disk_where buffer  + unaligned!
	#ilan_disk_length buffer  + unaligned!
	DROP
	\ addr n seek_pointer file_code(--
	buffer #ilan_disk_header_length
	['] perform_bank_op CATCH
	?DUP IF
		kill_buffer
		%bank_file_facility release
		$ABORT
	THEN 

	kill_buffer

	_lock_word 
	claim_bank

	\ The requested data is now in %bank_buffer
	%bank_file_table #flbus_count + W@ #ilan_disk_header_length < IF
		release_bank
		_unlock_word
		%bank_file_facility release

		$command_length_wrong $ABORT
	THEN

	\ The memory operations that can be done against dual port memory are limited
	\ as we will be writing the data to a user I/O area we cannot force long word
	\ operation so we need to copy to buffer.

	%bank_file_table #flbus_count + W@ 3 + -4 AND get_buffer
	%bank_buffer buffer %bank_file_table #flbus_count + W@ 3 + -4 AND MOVE	 

	release_bank
	_unlock_word
	
	buffer #ilan_disk_code + C@ #read_ilan <> IF
		%bank_file_facility release
		$strange_command $ABORT
	THEN
	buffer #ilan_disk_i/o_id + unaligned@ 
	<> IF
		%bank_file_facility release
		$wrong_file $ABORT
	THEN
	buffer #ilan_disk_where + unaligned@ <> IF
		%bank_file_facility release
		$wrong_file_pointer $ABORT
	THEN
	buffer #ilan_disk_length + unaligned@ TUCK
	\ addr n_in n_out n_in(--
	< IF
		%bank_file_facility release
		$wrong_length $ABORT
	THEN
	\ addr n_in(--
	DUP 
	%bank_file_table #flbus_count + W@ #ilan_disk_header_length - 
	<> IF
		%bank_file_facility release
		$?data_length $ABORT
	THEN
	\ addr n_in(--
	TUCK

	\ The count may be byte aligned and we have to respect it
	buffer #ilan_disk_header_length +
	-rot MOVE
	kill_buffer
	%bank_file_facility release
;
	 


: write_bank ( addr n seek_pointer file_code--)
	%bank_file_facility get
	jump  #ilan_disk_header_length + get_buffer
	#write_ilan #ilan_disk_code buffer + C!
	#ilan_disk_i/o_id buffer + unaligned!
	#ilan_disk_where buffer  + unaligned!
	DUP #ilan_disk_length buffer + unaligned!
	TUCK
	\ n add n (--
	buffer #ilan_disk_header_length + SWAP 3 + -4 AND MOVE
	\ n (--
	#ilan_disk_header_length + buffer SWAP
	['] perform_bank_op CATCH
	?DUP IF
		kill_buffer
		%bank_file_facility release
		$ABORT
	THEN 
	kill_buffer
	%bank_file_facility release
;


	io_common class
		
\		inode_interface implementation
		 
		protected

		
		ram_variable _%opened_files
			
		ram_create _%device_facility  #facility_length  ram_allot


		\ all opened inodes are liked into here
		ram_variable _%opened_inodes

		public



		\ bank
		\
		m:  ( parent_ihandle -- )
			\ If you want to change the root directory you open it, claim it and
			\ see that no one else has it. For this to work the open has to
			\ claim the device also.
			this :facility grab
				this [parent] :construct
			this :facility release
		; overrides :construct

		\ on object descruct get rid of file name.
		\ The closing of the rti file is done by the inode.
		m: ( --)
			this [parent] destruct
		; overrides :destruct


		\ After the device is opened by Sopen, the device open method is used
		\ to consume the reset of the open string.
		\ As a result the only structure that is fixed is the requirment that
		\ the open command starts with the driver name.
		\ On entry this is a device object, here we store the file name
		\ We make a inode object, this opens the file on the rti
		\ with the device locked.
		\ We then make a file object which we return

		m: ( addr num mode-- handle )
			this :!mode
			DUP not IF
				2DROP
				this
				EXIT
			THEN
			[CHAR] / remove_leading
			this :!name
			get_filecode
			this :open_inode 
			\ inode_handle(-- 
			this file_class heap_object  \ file_handle(--
			DUP %%file_instance !
		; overrides :Sopen


		m: ( --addr)
			_%opened_files
		; overrides :list_head


		\ device_common
		m: ( --addr)
			_%device_facility 
		; overrides :facility
	

		\ bank
		\ ----------------------------------------------------------------------
		\ functions to be overriden to have format work on different sized files
		\ number of inodes		
		\ total bytes in file system

		\ this has to be exported for file as file has to know how many bytes in a block
		\ when deblocking the data. We deal in 8k blocks		
		m: 
			$2000
		; overrides :bytes_a_zone


		\ ----------------------------------------------------------------------

		\ The file offset and disk offset are one the same
		m:  { ( file_offset ) variable _%inode -- ( disk_offset) }
		; overrides :file_offset>device_offset

		m: ( addr n -- n )
			\ need to supply file_code this is supplied from the inode_handle
			\ the pointer
			\ addr and n
			this :inode \ convert inode_handle to file_code
			%%seek_pointer @
			SWAP
			\ addr n seek_pointer file_code(--
			\ This is the device, when doing a read the device must be claimed 
			\ You are allowed only one active read
			this :facility grab
			read_bank
			this :facility release
			DUP %%seek_pointer +!
		; overrides :read


		m: ( addr n -- )
			this :inode
			%%seek_pointer @ 2DUP + >R
			
			SWAP
			\ addr n seek_pointer file_code(--
			this :facility grab
			write_bank
			this :facility release
			R> %%seek_pointer !
		; overrirdes :write
		
		\ opening a file makes it, just let this go by
		m: ( addr n --)
			2drop
		; overrides :make_file

		\ head for the device	
		m: ( --addr)
			_%opened_inodes
		; overrides :inode_head
			
		m: { variable _%inode ( -- ihandle) }
			this :facility grab			
			\ returns the head of the list
			this :inode_head   
			BEGIN
				@
			DUP WHILE
				\ link(--
				\ Following only words because all objects are children
				\ of linked_objects so method is the same
				DUP link>object \ object
				\ link object(--
				DUP :inode _%inode @ = IF
					\ link object(--
					\ This will increment the open count
					DUP :open
					this :facility release
					NIP
					\ object(--
					EXIT
				THEN
				DROP
			REPEAT
			DROP
			this :@name this :@mode _%inode @ 
			\ addr num mode code(--
			['] open_bank CATCH
			?DUP IF
				this :facility release
				$ABORT
			THEN 
			\ (--
			_%inode @ this inode_class heap_object
			this :facility release		
		; overrides :open_inode

		\ bank

		m: ( inode_instance --)
			\ claim the device 
			this :facility grab
			DUP :close IF
				\ :close returns true if the node can be closed
				DUP :inode  
				\ inode_instance file_code(--
				['] close_bank CATCH
				?DUP IF
					this :facility release
				THEN
				\ inode_instance
				DUP heap_object_free
			THEN
			DROP
			this :facility release	
		; overrides :close_inode 


		m: ( indent --)
			CR DUP SPACES ." bank | " ." Object: " this .h  
				SPACE ." file:" this :@name TYPE
			CR DUP SPACES ." seek_value: " %%seek_pointer @ .h 
			SPACE ." timeout: " %%timeout @ .h
			." linked_objects: " this :number_of_links .h 
			\ indent(--
			DROP send
		; overrides :print
target_also
&drivers
target_definitions
	end_class bank
target_previous_definitions
target_previous
./version081/bank_bvp5502_code.html0100777000000000000000000000646607300314345015630 0ustar rootroot COLDFORTH KERNEL license

Used to service cpi_i file service requests. The request is sent to the rti without going through the local file system. Faster but not 100% correct. 

 

: claim_bank ( --)
	BEGIN	
		BEGIN
			_#cpu_I_bank3_claim C@ 01 AND not 
		UNTIL
		TRUE _#cpu_II_bank3_claim C!
		_#cpu_I_bank3_claim C@ 01 AND not IF
			FALSE _#bank3_direction C!
			EXIT
		THEN
		FALSE _#cpu_II_bank3_claim C!
	AGAIN
;

: release_bank ( --)
		FALSE _#cpu_II_bank3_claim C!
;



	: interrupt_cpui_for_file
		_lock_word
		claim_bank
		TRUE %bank_ii_file !
		release_bank
		_unlock_word
		TRUE _#interrupt_other_cpu C!
	;

	: reset_i_interrupt
		TRUE _#interrupt_other_cpu_reset C!	
	;


	: send_error ( $ --)
		\ round to long words
		COUNT NIP 1+ \ allow room for code
		3+ -4 AND
		SWAP    \ length $(--
		OVER get_buffer   
			buffer 1+ #$buffer $move
			#error_ilan buffer C! 
			\ length(--
			
			_lock_word
			claim_bank
			
			buffer %bank_buffer jump MOVE
			%bank_file_table #flbus_count + W!
			
			release_bank
			_unlock_word 

		kill_buffer
		
		interrupt_cpui_for_file
	;


	: file_operation ( --)
		rti_facility get
		
		_lock_word
		claim_bank

		%bank_buffer %port_buffer %bank_file_table #flbus_count + W@ 
		DUP >R
		3+ -4 AND MOVE

		release_bank
		_unlock_word

		%port_file_table %port_(file_table) !
		%port_buffer %port_file_table #flbus_buffer + !
		R> %port_file_table #flbus_count + W!
		user_base activation_status %port_file_table #flbus_facility + !

		xtest
		
		TRUE %port_i_file W!
		
		interrupt_master
		
		#2sec 2*	xwait
		
		xtimeout? IF
			$" Master didn't process file request"  send_error
			rti_facility release
			EXIT
		THEN

		%port_file_table #flbus_count + W@

		_lock_word
		claim_bank

		%port_buffer %bank_buffer jump 3+ -4 AND MOVE
		%bank_file_table #flbus_count + W!

		release_bank
		_unlock_word

		interrupt_cpui_for_file
		rti_facility release

	;


	ram_variable %my_bank_facility #facility_length ram_allot
    
    : disk_action
			xsleep
			%my_bank_facility get		
			xnext
    		file_operation
    ;

While we could cheat with the RTI1000 bus terminal services and poll the dual port memory, we can't with bank terminal services, thay have to be interrupt driven. 

 

	interrupt: bank_interrupt
		TRUE _#interrupt_other_cpu_reset C!
		claim_bank
		%bank_i_file @ IF
			FALSE %bank_i_file !
			%my_bank_facility _#facility + @ ?DUP IF
				wake SWAP W!
				zero %my_bank_facility _#facility + !
			THEN
		THEN
\       %bank_i_app1 @ IF
\			FALSE %bank_i_app1 !        
\			start_relevent_task
\		THEN
	release_bank
	;interrupt


  	ram_variable %bank_task
  
	target_also
    &tasks 
	target_definitions

    #clock_low port_task: rti_ibm_serve 
		BEGIN 
			1 %bank_task +!
			disk_action 
		AGAIN 
	;task
	
	target_previous_definitions
	target_previous
./version081/bank_logon.html0100777000000000000000000001175407300314345014645 0ustar rootroot COLDFORTH KERNEL license

This is loaded into cpu2 

 
    | 1F CONSTANT #remote_develop
	\ the base address of the bank from cpu1's point of view
     ram_variable %bank_offset_i 

	: W!bank ( value addr --)
		_lock_word
		claim_bank
		W!
		release_bank
		_unlock_word
	;

	: !bank ( value addr --)
		_lock_word
		claim_bank
		!
		release_bank
		_unlock_word
	;

	: W@bank ( addr --value)
		_lock_word
		claim_bank
		W@
		release_bank
		_unlock_word
	;

	: @bank ( addr --value)
		_lock_word
		claim_bank
		@
		release_bank
		_unlock_word
	;

	: bank_move ( source dest num --)
		_lock_word
		claim_bank
		MOVE
		release_bank
		_unlock_word
	;

	: cpui>cpuii
		%bank_offset_i @  - _#bank_ram_base +
	;
	: bank_port_table ( port -- addr_us)
		_lock_word
		claim_bank
		%bank_pbase @ cpui>cpuii
		\ port base_address(--
		SWAP CELLS + @ DUP not IF
			release_bank
			_unlock_word 
			TRUE ABORT" Port not available"
		THEN
		cpui>cpuii
		release_bank
		_unlock_word
	;


	\ n1 is the time to wait
	\ addr is the facility address
	: bank_xgrab ( n1 addr --zero|$)
		BEGIN
			OVER 0>
		WHILE
			_lock_word
			claim_bank
			DUP @ 0= IF		\ count addr (--
			    status SWAP !
				release_bank
				_unlock_word
				DROP
				zero
				EXIT
			THEN
			DUP @ status = IF	\ count addr (--
				release_bank
				_unlock_word
				2DROP
				zero
				EXIT
			THEN
			release_bank
			_unlock_word
			xtest 0A xwait
			SWAP 0A - SWAP
		REPEAT
		\ get to here and the game is lost
		2DROP
		$can't_claim
	;

	: wake_bank_port_task ( addr -- )
		_#bank_ram_base -
		%bank_offset_i @ +
		BEGIN
			_lock_word
			claim_bank
			%bank_ii_unit @ not IF
				%bank_ii_unit !
				TRUE %bank_ii_terminal !
				release_bank
				_unlock_word
				TRUE _#interrupt_other_cpu C!
				EXIT
			THEN
			release_bank
			_unlock_word
			xpause
		AGAIN
	;

	: _bank_^C ( addr -- )
		_#bank_ram_base -
		%bank_offset_i @ +
		BEGIN
			_lock_word
			claim_bank
			%bank_ii_unit @ not IF
				%bank_ii_unit !
				TRUE %bank_ii_^ced !
				release_bank
				_unlock_word
				TRUE _#interrupt_other_cpu C!
				EXIT
			THEN
			release_bank
			_unlock_word
			xpause
		AGAIN
	;
    : _bank_logon ( port--)
		bank_port_table 'MLINK ! 
		\ this is not strickly correct as slave does not use
		\ address. But the location cannot be linked so this will do.
		064 'MLINK @ #p_owner + bank_xgrab ABORT" bank pipe busy."
		\ don't think we need to do this
		\ 'MLINK @ wake_bank_port_task 
	;

	: bank_release ( --)
		zero 'MLINK @ #p_owner + !bank
	;


    : _bank_logoff ( --)
		bank_release
		zero 'MLINK @ #p_request + W!bank
		zero 'MLINK @ #p_owner + !bank
		zero 'MLINK !
	;
    
    ( action codes)
    | 1 CONSTANT #expect_data
    | 2 CONSTANT #sending_data
    
    
    ( expect)
    | : expect_function ( --)
		#$buffer get_buffer
			buffer 'MLINK @ #p_count + W@bank #$maximum_data MIN ACCEPT
			\ n(--
			\ add in terminator
			1 CHARS +
			@u activation_^c_set W@ IF ( ^C )
				'MLINK @ _bank_^C 
				FALSE  @u activation_^c_set W! 
			THEN
    		buffer 'MLINK @ #p_address + @bank cpui>cpuii
    		jump  bank_move
    	kill_buffer
		'MLINK @ #p_actual + W!bank
	;
    
    ( type)
    | : type_function ( --)
		'MLINK @ #p_count + W@bank >R 
		R@ get_buffer
			'MLINK @ #p_address + @bank cpui>cpuii buffer R@ 
			3+ $FFFFFFFC AND \ count to long word boundry, buffe is always long word length 
			                 \ so result will fit. 
			bank_move
    		buffer R> _cvs_terminal_codes_decode
		kill_buffer 
	;
    
 
    | CREATE _bank_log_functions
    0 t,
    ' expect_function t,
    ' type_function   t,
   
	: (blogon) { ( port --)  }{
			2 CONSTANT _#max_function
		}

		'MLINK @ #p_function + W@bank IF
			zero 'MLINK @ #p_function + W!bank 
			'MLINK @ wake_bank_port_task
		THEN
		BEGIN

			KEY? 'MLINK @ #p_?data + W@bank <> IF
				KEY? 'MLINK @ #p_?data + W!bank
			THEN
    		
			@u activation_^c_set W@ IF ( ^C )
	    		'MLINK @ _bank_^C 
				FALSE  @u activation_^c_set W! 
			THEN

    		'MLINK @ #p_request + W@bank IF
    			'MLINK @ #p_function + W@bank 
				_#max_function MIN
				CELLS _bank_log_functions + @execute
    			zero 'MLINK @ #p_request + W!bank
				zero 'MLINK @ #p_function + W!bank 
 				'MLINK @ wake_bank_port_task
    		THEN 
			xpause 

		AGAIN 

	;



    : cpui ( --)
		\ same address for all task so a ram_variable
		\ doing this way reduces acesses to bank memory
		%bank_offset @bank %bank_offset_i !
		 #remote_develop  _bank_logon
		['] (blogon) CATCH
		_bank_logoff
		$ABORT
	;
./version081/bank_memory.html0100744000000000000000000000551307300314346015026 0ustar rootroot COLDFORTH KERNEL license

Bank memory is structure as described below

 
	HOST
	\ these must be the first dual bank varaiables defined
	'tbank @ _#bank_ram_base  ??=

	$20 CONSTANT #bank_tube_max
	
	bank_variable %bank_running         ( Set to 12345678 by slave)
	bank_variable %bank_pbase
	bank_variable %bank_offset
	bank_variable %bank_spare          
	bank_variable %bank_table_disk
	bank_variable %bank_(file_table)

	$20 _#bank_ram_base + 'tbank !
	bank_variable %bank_spare			
	bank_variable %bank_spare  

\ so the init routine can write into the correct location
 #BVP5501 [IF]
	bank_create %port_init_where
 [THEN]
         
	bank_variable %bank_init_where		( let others see where init up to)

	$40 _#bank_ram_base + 'tbank !
	\ The varibles are set i and used by ii
	bank_variable %bank_i_terminal
	bank_variable %bank_i_file
	bank_variable %bank_i_^ced
	bank_variable %bank_i_logoff
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_i_?who
	\ application
	bank_variable %bank_i_app_data
	bank_variable %bank_i_app_cmd
	bank_variable %bank_i_app_error
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_i_file

	$80 _#bank_ram_base + 'tbank !
	\ The varibles are set by ii used by i
	bank_variable %bank_ii_terminal
	bank_variable %bank_ii_file
	bank_variable %bank_ii_^ced
	bank_variable %bank_ii_logoff
	bank_variable %bank_ii_application
	bank_variable %bank_ii_?who
	bank_variable %bank_???????
	bank_variable %bank_ii_app_data
	bank_variable %bank_ii_app_cmd
	bank_variable %bank_ii_app_error
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_???
	bank_variable %bank_???


	$C0 _#bank_ram_base + 'tbank !
	bank_variable %bank_i_unit
	bank_variable %bank_ii_unit 



	$100 _#bank_ram_base + 'tbank !
	0 
	DUP	CONSTANT	#flbus_link 4+     ( for master)
	DUP CONSTANT	#flbus_source 2+   ( for master)
	DUP CONSTANT	#flbus_facility 4+ ( for slave)
	DUP CONSTANT	#flbus_count 2+    ( for slvae)
	DUP CONSTANT	#flbus_buffer 4+   ( for slave)
		CONSTANT	#flbus_length

bank_variable %bank_file_table #flbus_length 4 - bank_allot
bank_variable %bank_tube_control>  #bank_tube_max 4* bank_allot

\ The BCM522 expects this buffer to be the length of the maximum
\ ilan packet. It does give the best performance.
bank_create %bank_buffer #ilan_packet_max bank_allot
./version081/bank_tube.html0100777000000000000000000003152607300314346014466 0ustar rootroot COLDFORTH KERNEL license

Remember all this will go with TCP/IP and TELNET

bank_tube. This is object installed by the server. The server is the task providing the info. The terminal is the client. Same convention as the network, inverse convention to X. The control block must exist in banked memory. Because of history the bank_tube object has to allocated a number. This is the location the control block address is placed in the table pointed to by %bank_pbase. The object is created with the string bank_tube/nn for example to create an object for the operator task:

You have to remember through all this that the OPERATOR task has to be local and remote connectable. 

 
S" bank_tube/$1F" R/W OPEN-FILE $ABORT
 
 

	: W!bank ( value addr --)
		_lock_word
		claim_bank
		W!
		release_bank
		_unlock_word
	;

	: !bank ( value addr --)
		_lock_word
		claim_bank
		!
		release_bank
		_unlock_word
	;


	: C@bank ( addr --value)
		_lock_word
		claim_bank
		C@
		release_bank
		_unlock_word
	;

	: W@bank ( addr --value)
		_lock_word
		claim_bank
		W@
		release_bank
		_unlock_word
	;

	: @bank ( addr --value)
		_lock_word
		claim_bank
		@
		release_bank
		_unlock_word
	;

	: bank_move ( source dest num --)
		_lock_word
		claim_bank
		MOVE
		release_bank
		_unlock_word
	;


	\ n1 is the time to wait
	\ addr is the facility address
	: bank_xgrab ( n1 addr --zero|$)
		BEGIN
			OVER 0>
		WHILE
			_lock_word
			claim_bank
			DUP @ 0= IF		\ count addr (--
			    status SWAP !
				release_bank
				_unlock_word
				DROP
				zero
				EXIT
			THEN
			DUP @ status = IF	\ count addr (--
				release_bank
				_unlock_word
				2DROP
				zero
				EXIT
			THEN
			release_bank
			_unlock_word
			xtest 0A xwait
			SWAP 0A - SWAP
		REPEAT
		\ get to here and the game is lost
		2DROP
		$can't_claim
	;


	: bank_release ( add --)
		zero SWAP !bank
	;

	tube class
		m: ( --)
			\ does the unlinking
			this [parent] :destruct
		; overrides :destruct

		\ This will set up up as a normal tube, it is Sopen that converts us to
		\ port_tube
		m: ( number parent--)
			this [parent] :construct
		; overrides :construct
		
		\ you can open the device and particular port with the code
		\ bank_port/nn
		\ this code should receive the string nn.
		\ As the open operation creates the bank port memory area
		\ the device must be opened and closed from a task that has bank
		\ memory to allocate ( all owned by operator in the begining)
		\ before the device is opened by a task not having the memory to allocate.

		m: ( addr num mode-- handle )
			this :!mode
			\ because thats what out I/O standard expect us to do.
			[CHAR] / remove_leading
			2DUP this :!name
			\ because this is what we want
			Snumber \ number(--
			DUP #bank_tube_max < not ABORT" Port number out of range"
			\ Now this may seem strange but we have to take care. 
			DUP CELLS %bank_tube_control> +  
			_lock_word 
			claim_bank
			@ 
			not IF
				\ We can not store a random number as master side will only test for zero.
				\ This is not 100% correct but as we can no longer save a binary
				\ image of the application it's ok. Run time code is allocating bank
				\ memory; thats the problem. Note we take care to only allocate
				\ it once for each port. The memory belongs to the port not the object.
				\ There is no place to return it so once allocated it remains until
				\ the system is restarted. A system restart reloads the application.
				\ Obviously the port has to be opened first in a task that has bank
				\ memory to allocate.
				bank_here \ num base(--
				\ this could be nasty an ABORT with interrupts disabled
				_#control_block_size ['] bank_allot CATCH ?DUP IF
					release_bank
					_unlock_word $ABORT
				THEN
				\ num base(--
				DUP _#control_block_size
				ERASE
				bank_here OVER #p_tpoint + !
				_#write_buffer_length 
				['] bank_allot CATCH ?DUP IF
					release_bank
					_unlock_word $ABORT
				THEN
				OVER \ num base num(--
				CELLS %bank_tube_control> + !
			THEN
			release_bank
			_unlock_word
			\ num(--
			CELLS %bank_tube_control> + @bank this :!control_block
			this
		; overrides :Sopen

	\ the contol block is in dual port memory
	\ Shit; I know but all this is being repelaced by TCP/IP
	\ so it is a waste of time doing it any other way.
	: _bank_send  ( addr count --)

			DUP not IF \ Don't send null packet.
				2DROP 
				xpause 
				EXIT 
			THEN 

			10 %%control_block> @ #p_status + bank_xgrab $ABORT
			\ for the ^C
			user_base activation_status this :@control_block #p_^C_task + !bank


			\ addr count(--

			\ Only pause if there is an owner. This feature
			\ allows you to use tubes for debugging. If no one
			\ is logged on the message is gobbled up. If logged
			\ on you get the message.
			%%control_block> @ #p_owner + @bank %%always_send @ OR IF

				#send_code %%control_block> @ #p_function + W!bank
	    		DUP %%control_block> @ #p_count + W!bank

				FALSE %%control_block> @ #p_?data + W!bank
    		
				xsleep 

				%%control_block> @ #p_local + W@bank IF 
					\ If local is set there is an owner
					\ addr count(--
					DROP
					%%control_block> @ #p_address + !bank
					
					TRUE %%control_block> @ #p_request + W!bank
					
					wake %%control_block> @ #p_owner + @bank W!
					
					xnext
				ELSE
					\ addr count(--
					\ If remote move data into bank transfer buffer)
					\ addr count(--
	    			%%control_block> @ #p_tpoint + @bank SWAP 
					_#write_buffer_length MIN 
					3 + $FFFFFFFC AND 
					\ addr addrfrom addrto count(--
					bank_move
				
					%%control_block> @ #p_tpoint + @bank
					%%control_block> @ #p_address + !bank
				
					TRUE %%control_block> @ #p_request + W!bank
					xnext
				THEN
			ELSE
				2DROP
				\ xpause
			THEN
			%%control_block> @ #p_status + bank_release
		;
    

		m: ( --)
			\ terminate the write buffer with a send
			$82 %%type_buffer> @ %%type_buffer_count @ + C!
			1 %%type_buffer_count +!
			%%type_buffer> @ %%type_buffer_count @ 
			_bank_send
			zero %%type_buffer_count !
		; overrides :flush_file

		: read_common ( addr num --addr )
			send
			10 %%control_block> @ #p_status + bank_xgrab $ABORT

			\ for ^C
			user_base activation_status this :@control_block #p_^C_task + !bank

			#expect_code  %%control_block> @ #p_function + W!bank
		    #p_count %%control_block> @ + W!bank
			\ addr(--
			%%control_block> @ #p_local + W@bank TUCK IF
				\ if local point to buffer
				DUP #p_address %%control_block> @ + !bank
			ELSE
				\ if remote we have to transfer data to
				\ transfer buffer.
				%%control_block> @ #p_tpoint + @bank
				%%control_block> @ #p_address + !bank
			THEN

			\ local addr (--

			zero %%control_block> @ #p_actual + W!bank 
    		
			xsleep 
			
			TRUE %%control_block> @ #p_request + W!bank
			
			%%control_block> @ #p_owner + @bank  IF
				OVER  IF
					%%control_block> @ #p_owner + @bank
					wake SWAP  W!
				THEN
			ELSE
				\ If no one is logged on seal the interpreter
				TRUE seal W!
			THEN	
    		
			xnext

			\ local addr(--

			\ If not local data is now in buffer pointed to by address, we now copy it 
			\ to the users buffer. Look at port_tube for reason.
			SWAP not IF
				%%control_block> @ #p_address + @bank
				OVER
    			%%control_block> @ #p_actual + W@bank \ includes termination code
				\ long word align, makes for faster copy. And as dual port
				\ will only allow word moves a valid copy.
				3+ $FFFFFFFC AND 
				\ from to num (--
				bank_move
			THEN
		;

		\ Once we have set up for a local read we have to be committed to 
		\ the local read. Ii is possible for the local task to log off and
		\ a remote task to log on.    
		m: ( addr num --  num_bytes ) 
			\ addr(--
			read_common
			DROP
			%%control_block> @ #p_actual + W@bank 1- \ exclude termination code
			%%control_block> @ #p_status + bank_release
		; overrides :read

		\ addr is the start of the buffer
		\ n is the numbr of characters including the terminator
		m: ( addr num --  num_bytes )
			read_common
			\ addr(--
    		%%control_block> @ #p_actual + W@bank
			\ deal with termination 
			this :termination>code
			
			%%control_block> @ #p_status + bank_release

		; overrides :read_line

		m: ( indent --)
			CR DUP SPACES ." bank_tube | " ." Object: " this .h  
			DROP send
		; overrides :print

target_also
&drivers
target_definitions

	end_class bank_tube

target_previous_definitions
target_previous

The client. If we have the control block we can fiddle with that and not get involved any further. These words will work agains a tube or port_tube. The data is moved through the buffer pointed to by tpoint because port_tube requires this action. 

 

		| : _expect_action { ( control_block --control_block) }{
				variable %terminator
			}
			\ have to receive into a buffer as the receive area may be in
			\ dual port memory.
			DUP #p_count + W@bank get_buffer
				buffer OVER #p_count + W@bank ACCEPT 
				\ control_block count(--
				buffer jump #p_address + @bank 
				\ control_block count buffer addr(--
				jump 
				1 + \ add in terminator 
				3+ $FFFFFFFC AND \ round to long word count
				MOVE 
			kill_buffer
			\ control_block actual_count(--
			\ we want control C set befor the task is told about expect
			user_base activation_^c_set W@ IF ( ^C )
				TRUE jump #p_^C + W!bank
				FALSE user_base activation_^c_set W!
				OVER #p_^C_task + @bank 
				IF
					TRUE jump #p_^C_task + @bank 
					[ #activation_^c_set #activation_status - ]T LITERAL + W!
				THEN
			THEN
			'input_file @ :terminal_mode@ IF 
				OVER #p_address + @bank OVER + C@bank %terminator !
			ELSE
				\ in binary mode there is no terminator
				zero %terminator !
			THEN
			1 CHARS + \ add in termination code 
			OVER #p_actual + W!bank
			KEY? OVER #p_?data + W!bank
			xtest
			DUP #p_status + @bank ?DUP IF
				wake SWAP  W!
				zero OVER #p_function + W!bank
			THEN
			%terminator @ #end_eof = ABORT" Disconnected"
		;


		| : _type_action   ( control_block --control_block)
			DUP #p_address + @bank 
			OVER #p_count + W@bank
			\ remember the type data will not be in the 
			\ banked memory
			_cvs_terminal_codes_decode
			KEY? OVER #p_?data + W!bank
			\ wake up task we are supplying terminal services too
			xtest
			DUP #p_status + @bank ?DUP IF
				wake SWAP  W!bank
				zero OVER #p_function + W!bank
			THEN
		;
         
		| : _no_action ( control_block -- control_block)
              
		;
         
         CREATE  function.vectors
         4 tw,
         ' _no_action     t,
         ' _expect_action t,
         ' _type_action   t,
         ' _no_action     t,
         
		\ the operator task has to expose it's tibe to the bank memory and
		\ we have to use this word.
		: bank_logon  ( object--)
			:@control_block
			10 OVER #p_owner + bank_xgrab $ABORT
			TRUE OVER #p_local + W!bank
			

			\ Old rlogon code reset request on logoff. We need to turn to the function
			\ code. If the function code is non zero then it is a safe bet that
			\ the task is waiting for the terminal. The old logon code doesn't
			\ reset the function code under normal operation so there is a risk
			\ but small.
			DUP #p_function + W@bank IF 
				DUP #p_status + @bank ?DUP IF
					wake SWAP  W!
					zero OVER #p_function + W!bank
				THEN
			THEN

			\ control block(--
			BEGIN
				user_base activation_^c_set W@ IF ( ^C )
					TRUE OVER #p_^C + W!
					FALSE user_base activation_^c_set W!
					DUP #p_^C_task + @bank 
					IF
						TRUE OVER #p_^C_task + @bank 
						[ #activation_^c_set #activation_status -]T LITERAL + W!
					THEN
				THEN
				DUP #p_request + W@bank IF
					FALSE OVER #p_request + W!bank
					DUP #p_function + W@bank 
					\ as we use the function code on logon to
					\ determine if the task is waiting for 
					\ the terminal we must set it to zero in
					\ normal operation, if we wake te task.
					\ limit to number of vectors in table
					function.vectors W@ 1- MIN
					\ get vector
					4* function.vectors + 2 + @
					CATCH ?DUP IF
						\ addr $(--
						\ a remote logon will not set this
						\ flag so the default has to be remote.
						FALSE jump #p_local + W!bank
						SWAP #p_owner + bank_release \ $ (--
						$ABORT
					THEN
				THEN
				2 xwait
			AGAIN
		;
./version081/base_altering.html0100777000000000000000000000226007300314346015324 0ustar rootroot COLDFORTH KERNEL

Words to alter base

license

The base is used for number to conversion.

ANS 6.1.1170 DECIMAL ( --)

CORE

( -- )

Set the numeric conversion radix to ten (decimal). 

 
	: DECIMAL ( --)   
		$0A BASE ! 
	;
ANS 6.2.1660 HEX ( --)

( -- )

CORE EXT

Set contents of BASE to sixteen. 

 
	: HEX ( --)
		$10 BASE !
	;
binary (--)

Set the contents of BASE to two. 

 
	: binary  ( --)   
		#02 BASE ! 
	;
octal (--)

Set the contents of BASE to eight. 

 
	: octal   ( --)   
		#08 BASE ! 
	;
./version081/basic_io.html0100777000000000000000000000612207300314346014276 0ustar rootroot COLDFORTH KERNEL license
See send 
 
	| CREATE (_send_) 0 t,
	| : send (_send_) @execute ;
See TYPE 
 
	| CREATE (_type_) 0 t,
	| : TYPE ( addr num --)
		(_type_) @execute 
	;
	
	\ Non standard
	\
    : $type   ( addr --) COUNT TYPE ;
See EXPECT 
 
	| CREATE (_expect_) 0 t,
	| : EXPECT ( addr num --)
		(_expect_) @execute ;
ANS 6.1.1320 EMIT

( x -- )

If x is a graphic character in the implementation-defined character set, display x. The effect of EMIT for all other values of x is implementation-defined.

When passed a character whose character-defining bits have a value between hex 20 and 7E inclusive, the corresponding standard character, specified by 3.1.2.1 Graphic characters, is displayed. Because different output devices can respond differently to control characters, programs that use control characters to perform specific functions have an environmental dependency. Each EMIT deals with only one character. 

 
	\ can't use the stack as we are not allowed to take the
	\ stack address. Using a buffer is a bit over the top so
	\ we will allocate a user variable for the job.
	\
	uvariable _emit_buffer
	: EMIT ( char --)
			_emit_buffer C!
			_emit_buffer one 
			TYPE 
	;
	 
 
	CREATE (_cr_) 0 t,
	| : CR (_cr_) @execute ;
visible ( from num to --)

Move the characters from the buffer described by from and num to the buffer pointed to by to. Make sure the characters are in a visible range. Useful for printing ascii text out to terminals that will interpret some characters as control characters. 

  


	: visible ( from num to --)
		-rot               \ to from num (--
		OVER               \ to from num from (--
		+                  \ to start end (--
		SWAP               \ to end start (--
		DO                 \ to (--
			I char@ 
			DUP BL < IF    
				DROP [CHAR] ~
			THEN
			DUP [CHAR] ~ > IF
				DROP [CHAR] ~
			THEN
			OVER char!
			CHAR+
		[ 1 CHARS ]T LITERAL +LOOP
		DROP
	;

Convert invisible caracters to ~ 

 
	: ~TYPE ( addr num --)
		DUP IF   
			$buffer
				TUCK			\ num addr num (--
				buffer visible		
			    buffer SWAP     \ addr num (--
				TYPE
			kill_buffer
		ELSE 
			2DROP 
			xpause 
		THEN 
	;

	: ^C ( --)
		user_base activation_^c_set W@ IF
			FALSE user_base activation_^c_set W! 
			TRUE ABORT" ^C detected." 
		THEN 
	;
./version081/bcm550.doc0100777000000000000000000020500007300314346013316 0ustar rootrootࡱ> uxv|G Gbjbjَ *C],,,,,,,@@@@@$d\@2$  n,,, ,,@@,,,,.>V3@,,<@@@ s Overview A brief overview of the BCM550 functions: One MCF5307 Coldfire RISC processor operating at 45MHz and with 32Meg of SDRam. A Reset pushbutton and Cold/Normal/Warm start selector switch. Boot Flash, 512K by 8, socked mounted. Copy flash facility, 512K by 8, socked mounted. Application Flash 1Meg by 16, PCB mounted. RTI Dual Port area 8K by 16 which is active in both master and slave modes. Ethernet Device providing an isolated RJ45-8 connection, Interrupt facility and DMA access. Remote IO unit, providing fiber optic connection to remote modules, interrupt facility and dual port memory access to the Coldfire. A fully implemented RTI-1000 Bus master, providing access to 16 RTI-1000 slots, full interrupt facility and handshake signals to the RTI-1000 backplane. A fully implemented RTI-1000 Slave providing dual port memory access and interrupt facility. Also, a programmable RTI-1000 ID. Two communications Ports are provided. Port One is programmed to operate in either a RS232 mode or a RS485 mode. Port 2 is an RS485 port, programmed to operate in either a half or full duplex mode. All RS485 ports are electrically isolated. Two isolated digital inputs, which can be read as status inputs or can be programmed to interrupt the Coldfire on a rising edge, falling edge or on both a rising and falling edge. Watchdog timer output that can be programmed to reset the BCM550. Led indicators for transmit and receive signals on communications ports 1 and 2, transmit and receive signals on the Ethernet interface, Digital Inputs 1 and 2, three programmable leds and the reset line. A Function Facility which incorporates 4 general purpose R/W registers, 2 R/W control registers, Input status register, Interrupt status register, ID register, Coldfire and RTI-1000 Interrupt facility and Coldfire DMA control. Power On Sequence On application of power, the Coldfire enters a reset state and reads the status bits on D00 to D07. These bits are set to preset the VCO and set the input frequency range to the Coldfire. Also, the Boot flash is defined has 8 bits and with auto-acknowledge and the parallel port is preset. Reset is not released until the programmable logic device is loaded from its attached prom. After the PLD is loaded and 10 system clocks have occurred reset will be deactivated and instruction execution will begin from the Boot flash at address $0. System Memory The system memory comprises of four 4-Meg by 16 Synchronous Dram devices. These components are arranged in two banks of 4-Meg by 32, providing the user with a total of 32Mbytes. The devices used are Microns MT48LC4M16A2TG-10 and are internally arranged in 1Meg by 16 by 4 banks. The devices are rated at 66MHz with a CAS latency of 2 clocks or 9nsec, a setup time of 3nsec and a hold time of 1nsec. In the current design these parts will operate at 45MHz. Procedure to Enable the System Memory: After Power is applied and all clocks are running and stable a 100usec delay is required before the SDRam accepts commands. During this time the MCF5307 SDRam controller registers can be setup. DCR = Dram Control Register Value = $822B This value sets the controller to synchronous operation, enables address multiplexing, sets the SCKE pin to clock enable, sets the refresh timing to 6 bus clocks, and finally sets the refresh count to 43. Also this value uninitiated self refresh. Note: The Refresh timing is obtained from the Trc spec of the SDRam. It is given has 90nsec which at a 66MHz clock refers to 6 clock cycles. This value is NOT downgraded for a 45MHz clock. The Refresh count is obtained from the refresh cycle timing which states 4096 refresh cycles in 64msecs. This means maximum time period for refresh is 15.625usecs. This equates to 703.125 bus clocks at 45Mhz. To convert this to a RC field value, RC = (703.125/16)-1=42.945. This value indicates the maximum delay between refreshes. A value of 43 is used. DACR0 = Address and Control Register for Bank 0 Value = $10001404 DACR1 = Address and Control Register for Bank 1 Value = $11001404 This value sets the base address for Bank 0 to $10000000 and bank 1 to $11000000. Also the value disables refresh, sets the Column latency value to 2, sets the bank multiplex value to 4, disables the mode register command, sets the port size to 32 bit, disables the pre-charge command, and sets the SDRam in continuous page mode. Note: The column latency value is obtained from the access time specification Trcd. DMR0 = Mask Register for Bank 0 Value = $01FC0001 DMR1 = Mask Register for Bank 1 Value = $01FC0001 This value sets the mask register to ignore bits A24 and below and also sets the SDRam to enable writes, enable address masks for CPU Space / Interrupt Acknowledge, Alternate Master, Supervisor Code, Supervisor Data, User Code and User Data. Also the V bit is set to 1 enabling SDRam access. These 5 registers complete the MCF5307 SDRam register setup phase. b) After the above step and the necessary 100usecs delay (4500 clocks), issue a pre-charge all command by setting the IP bit (bit 3) in the DACRx register to a one and then accessing any memory location in the associated SDRam. For Bank 0, set the DACR0 Register to $1000140C and followed by a write from memory location $10000000, $10400000, $10800000 and $10C00000. For Bank 1, set the DACR1 Register to $1100140C and followed by a write from memory location $11000000, $11400000, $11800000 and $11C00000. Each pre-charge command takes 30nsecs to complete so it would be advisable to add a delay between commands. On completion of the pre-charge command the SDRam enters an idle state. Note: The DACRx registers are read/write registers, hence masking may be an easier option that presetting values. Also, a pre-charge command must be issued to each internal bank in order to set that bank in the idle state. c) Next enable refresh by setting the RE bit (bit 15) in the DACRx register to a one. For Bank 0, set the DACR0 Register to $10009404. For Bank 1, set the DACR1 Register to $11009404. Once the Refresh commands have been enabled wait for at least two refresh cycles to be completed. Each refresh cycle takes 64msecs. After these commands are completed you can program the SDRam mode register. Commands to the SDRam are issued via the address lines and are dispatched simply by accessing a specific address in the SDRam address range that corresponds to the desired bit pattern for the command being given. The mode register on the SDRam has 12 bits. Bits 0-2 determine the burst length. Bit 3 identifies the burst type. Bits 4-6 set the CAS latency, while bits 7-8 define the mode of operation. Bit 9 establishes the write burst mode, while bits 10 to 11 are reserved and should be programmed with zeroes. A mode register setting of $220 causes the SDRam to operate in the following manner: Burst Length = 1 Burst Type = Sequential CAS Latency = 2 Clocks Operating Mode = Standard Operation Write Burst Mode = Single Location Access To program this information into the SDRam mode register, set the IMRS bit (bit 6) to one in the DACRx register, and immediately issue a write has follows: For Bank 0, set the DACR0 Register to $10009444 followed by a write to $10000220. For Bank 1, set the DACR1 Register to $11009444 followed by a write to $11000220. The SDRam controller will then load the SDRam mode register with the necessary value. After the mode register is programmed, reset the DACRx registers to $1009404 for Bank 0 and $1109404 for Bank 1. Now normal memory operation can begin. The first item on the agenda is to carry out a through memory test. This test must include a test on each bit in the 32Meg array and also on refresh. After these tests complete satisfactory then the system memory can be handed over to the user. The above sequence of operation is to be carried out after each reset and prior to any caching setups. Chip Selects CS0: Boot Flash 512K by 8 bits - Byte access only Read only - 120nsec - Socket Mount CSAR0 = $0000 ; Starts at address $00000000 CSMR0 = $00070001 ; Address range from $00000000 to $0007FFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR0 = $1940 ; 6 Wait states, AA=1, PS=8 bit, BEM=0, BSTR=0, BSTW=0 CS1: Application Flash 1Meg by 16 bits - Word access only - Read/Write - 120nsec - PCB Mount CSAR1 = $0020 ; Starts at address $00200000 CSMR1 = $001F0001 ; Address range from $00200000 to $03FFFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR1 = $1980 ; 6 Wait states, AA=1, PS=16 bit, BEM=0, BSTR=0, BSTW=0 CSBAR = $0000 ; Set CS2 to CS7 at a base address of $00000000 CS2: RTI Dual Port Memory 8K by 16 bits - Word access only - Read/Write - 55nsec - PCB Mount CSMR2 = $00000001 ; Address range from $00400000 to $0040FFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR2 = $0DA0 ; 3 Wait states, AA=1, PS=16 bit, BEM=1, BSTR=0, BSTW=0 CS3: Ethernet Controller 16 by 16 bits Word access only Read/Write Ack signal PCB Mount CSMR3 = $00000001 ; Address range from $00600000 to $0060FFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR3 = $0080 ; 6 Wait states, AA=1, PS=16 bit, BEM=0, BSTR=0, BSTW=0 CS4: Remote IO Dual Port Memory 1k by 8 bits Byte access only Read/Write 55nsec PCB Mount CSMR4 = $00000001 ; Address range from $00800000 to $0080FFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR4 = $0D40 ; 3 Wait states, AA=1, PS=8 bit, BEM=0, BSTR=0, BSTW=0 CS5: RTI Bus 1Meg by 16 bits Word access only Read/Write Ack signal Backplane access CSMR5 = $000F0001 ; Address range from $00A00000 to $00AFFFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR5 = $0080 ; 0 Wait states, AA=0, PS=16 bit, BEM=0, BSTR=0, BSTW=0 CS6: Boot Copy Flash 512K by 8 bits Byte access only Read/Write 120nses Socket Mount CSMR6 = $00070001 ; Address range from $00C00000 to $00C7FFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR6 = $1940 ; 6 Wait states, AA=1, PS=8 bit, BEM=0, BSTR=0, BSTW=0 CS7: Functions 32 by 8 bits Byte access only Read/Write 35nsec PCB Mount CSMR7 = $00000001 ; Address range from $00E00000 to $00E0FFFF ; WP, AM, C/I, SC, SD, UC, UD = 0, V = 1 CSCR7 = $0540 ; 1 Wait states, AA=1, PS=8 bit, BEM=0, BSTR=0, BSTW=0 Function Data Function Data provide the user with a set address and data registers that are used for a various number of functions that include, 4 general purpose R/W registers, 2 R/W control registers, Input status register, Interrupt status register, ID register, Interrupt handling facility and DMA control. Function 00 Address $00E00000 - Write Only Valid Data Latch value into the high byte RTI ID. On reset the RTI ID value is set to $0005. Function 01 Address $00E00001 R/W Pulse latched Output the latch data value to the high byte on the RTI ID. Function 02 Address $00E00002 R/W - Pulse Reset Interrupt for Digital Input 1. Function 03 Address $00E00003 R/W - Pulse Reset Interrupt for Digital Input 2. Function 04 Address $00E00004 R/W - Pulse Reset Interrupt for RTI Ac-low. Function 05 Address $00E00005 R/W - Pulse Reset Interrupt for RTI Sys-Fail. Function 10 Address $00E0000A R/W - Pulse Send End of Service Signal to the NICE Ethernet Device. Function 16 Address $00E00010 R/W Valid Data One of four general purpose registers. Function 17 Address $00E00011 R/W Valid Data One of four general purpose registers. Function 18 Address $00E00012 R/W Valid Data One of four general purpose registers. Function 19 Address $00E00013 R/W Valid Data One of four general purpose registers. Function 27 Address $00E0001B R/W Valid Data Control Register 0 Reset Value = 0 Bits defined has follows: Bit 0 Enable Programmable logic Bit 1 Enable Tout1 to be used has external reset. Bit 2 Causes a self reset Bit 3 Spare ( Not Implemented ) Bit 4 Spare ( Not Implemented ) Bit 5 Spare ( Not Implemented ) Bit 6 Spare ( Not Implemented ) Bit 7 Spare ( Not Implemented ) Function 28 Address $00E0001C R/W Valid Data Control Register 1 Reset Value = 0 Bits defined has follows: Bit 0 Programmable Led 1 Bit 1 Programmable Led 2 Bit 2 Programmable Led 3 Bit 3 Spare ( Not Implemented ) Bit 4 Communications Port 1 Reset = RS232 / Set = RS485 Bit 5 Communications Port 2 Reset = Half Duplex / Set = Full Duplex Bit 6 Digital Input SB0 See table below Bit 7 Digital Input SB1 See table below Digital Input Selection SB1SB0Function00No Digital Input Interrupts - Status Only01Interrupt on falling edge only10Interrupt on rising edge only11Interrupt on both falling and rising edges Function 29 Address $00E0001D Read Only Valid Data Digital Input Status Register Bit 0 RTI/Slot0-n Bit 1 Sw/Cold-n Bit 2 Sw/Warm-n Bit 3 Digital Input 1 Bit 4 Digital Input 2 Bit 5 Zero Bit 6 Zero Bit 7 Zero Function 30 Address $00E0001E Read Only Valid Data Interrupt Status Register Bit 0 Digital Input 1 Interrupt has set per SB0 and SB1 Bit 1 Digital Input 2 Interrupt has set per SB0 and SB1 Bit 2 RTI-Aclow Interrupt Bit 3 RTI-Sysfail Interrupt Bit 4 Remote I/O Interrupt Bit 5 Zero Bit 6 Zero Bit 7 Zero Function 31 Address $00E0001F Read Only Valid Data FPGA Version Register ( $A1 ) Bit 0 1 Bit 1 0 Bit 2 0 Bit 3 0 Bit 4 0 Bit 5 1 Bit 6 0 Bit 7 1 Function 32 Address $00E00020 R/W - Pulse Set Interrupt to RTI-1000 ( Used in slave mode only ). Function 33 Address $00E00021 R/W - Pulse Reset Interrupt from RTI-1000 (Used in slave mode only ). Interrupts Three external interrupts are catered for on the BCM550. The NICE Ethernet controller device controls the level 1 interrupt. A level 3 interrupt can be generated through various sources. These include, Digital Input 1, Digital Input 2, RTI/Ac-low, RTI/Sys-fail, and the Remote IO. The source of the level 3 interrupt can be found from the Interrupt status register, Function 30. All interrupts to this level are latched and should be reset has part of the interrupt routine. Functions 2 to 5 reset the digital inputs, and the RTI interrupts. Writing to its second last address in its dual port memory area resets the remote/IO interrupt. A level 5 interrupt is caused by the RTI1000. When the BCM550 is in slot 0, this interrupt will cause an interrupt acknowledge cycle to occur which in turn will provide a auto-vectored interrupt address. If the BCM550 is a slave card, the interrupt from the RTI-1000 is latched an reset by Function33. Function 32 sets an interrupt to the RTI-1000 master. DMA Access The Coldfire caters for two DMA channels. The NICE device provides the only DMA request on the BCM550. Timer The MCF5307 provides the user with two timers. In the current design Timer 0 is to be used for the 10msec interrupt. Timer 1, is used has a watchdog. The output of Timer 1, Tout1, is included in the reset logic to cause a reset to the BCM550 when the watchdog times out. Setting bit 1 in control register 0 enables this feature. Communications Three communications ports are provided on the BCM550. Two communications ports are provided by the MCF5307 and the NICE peripheral device provides the third port. MCF5307 Uart 1: This Uart provides the user with either an RS232 or an RS485 communications channel. The default condition is operation as a RS232 port. Setting bit 4 in control register 1 enables the RS485 communications port. Led indicators are provided on receive and transmit signals. MCF5307 Uart 2: This provides the user with an RS485 communications channel that operates in either a half or full duplex mode. The default condition is operation in half duplex mode. Setting bit 5 in control register 1 enables the full duplex option. Led indicators are provided on receive and transmit signals. Ethernet Controller: The NICE Ethernet controller device, MB86960 and 10Base-T Interface device, MB86961 provide the BCM550 with an Ethernet communications port. The NICE device, can be set up has an interrupt to the MCF5307. Alternatively, the device can function in a DMA mode for send and receive data packets. An end of service flag is set through Function 10. Led indictors are provided on receive and transmit signals. Digital Inputs The BCM550 caters for 2 digital inputs. These inputs can be viewed for status values or alternatively can be programmed to provide an interrupt to the Coldfire on the rising edge, falling edge or both. See Control Register 1. Remote IO The Remote IO function is established through a fiber-optic link and is incorporated by a programmable controller and a programmable logic device. Data transmission between the Coldfire and the Remote IO unit is achieved through a 1k by 8 bit dual port memory device. The Coldfire receives an interrupt from the Remote IO unit when the Remote IO unit writes to location $3FF. The Coldfire clears the interrupt by accessing location $3FF. Likewise, the Remote IO unit interrupt flag is asserted when the Coldfire writes to location $3FE and to clear the interrupt the Remote IO unit must assess location $3FE. The message at $3FE and $3ff is user defined.  % 7 U V d 1X @E^dO7KQ]f MQWcmq  " + C L b g t } (!.!;!C!S![!5CJhnH  CJhnH  CJOJQJ5B*CJhnH 5B*CJhnH B*CJhnH 5CJCJOJQJhnH OJQJhmH nH H   56Gs |1 s @ # $ % 7 8 9 \ U d  & F   56Gs |1 s @ # $ % 7 8 9 \ U d e f 01XYGºzwtqnhe          u        m        ;  z    &d e f 01XYG>^, MO7Oh h hh & FG>^, MO7O=opq4`N """" #T###¿~xuro     e ]  @B!b@rC*O=opq4`N """" #T#h h & F hh[!"""" #T#[#^#c#########5$M$$$$$$$$$,%1%5%:%t%%%%%&&&&&&&&&&&)'.'2';'''''''@(E(I(R(((((()Q)V)Z)c)))))**c*h*l*u*****+%+B*CJhnH CJmH 5B*CJhnH CJOJQJhnH  CJhnH VT####5$M$$$%,%t%u%%%%&S&&&&)'h''''@((((##5$M$$$%,%t%u%%%%&S&&&&)'h''''@(((()Q)))**c***+%+h+++,),*,+,~{xuCo  6c 1^ (3` =b P 5s 7d,()Q)))**c***+%+h+++,),*,+,T-U-V---.U....%+h+m+q+z+++++,,+,V-a---U.`..../I/T///0 0[0f00011i1u1 3344555667788 99v99g=r====.?/?>??? AACBXBCCθΰθ¸άθhnH 5CJhnH OJQJhmH nH 5CJOJQJhnH CJOJQJhnH 5CJOJQJhnH  B*hnH B*CJhnH 5B*CJhnH CJmH D+,T-U-V---.U.....'/I/u////0020[00001@1i1j11111262U2y2222 3;3P3b3|333~{xu} 1Uy:Tf{0aP|}Bn3...'/I/u////0020[00001@1i1j11111262U2y22222 3;3P3b3|3333364~44444444555 545ռ$$$l d4$$33364~44444444555 545557595X5Y5[5]5{5|5~55555566.6C6]6w66þ|yvspmjgda{EFG  r  t  vw                          , -lB`&45557595X5Y5[5]5{5|5~55555566.6C6]6w6666$$$$$l d466666607l7777777*8J8V8b8n8z8888888 989t99999:<e=f=g=r=s=t====}yuq       6 o p q ~KLXblx)HhQRan+666607l7777777*8J8V8b8n8z8888888 989t999999:<e=f=g=r=s=t=======.?>???@????@A AABBB====.?>???@????@A AABBBCBXBCCCCDDDDDDDEG         BBCBXBCCCCDDDDDDDEGCDDGOJQJhmH nH CJOJQJhnH (&P . A!"#$% [$@$NormalmH H`H Heading 1$@& hCJOJQJhnH B`B Heading 2$@&5B*OJQJhnH 8`8 Heading 3$@& 5CJmH 8`8 Heading 4$@& 5CJmH <A@<Default Paragraph FontJC`JBody Text IndenthB*OJQJhnH RR`RBody Text Indent 2h B*CJhnH C[!%+CG28<Gd OT#(.24569BBG3579;>?ACDFG#+,36=G46:=@BECCAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec'C:\TEMP\AutoRecovery save of bcm550.asdAleksander Slavec'C:\TEMP\AutoRecovery save of bcm550.asdK ~ n& {ik hho()hho()hho()K{ik~ n&@e e he e C`@GTimes New Roman5Symbol3& Arial?Times-Roman;"Helvetica"h+& ,F ,FF= 7v$r0dYDsAleksander SlavecAleksander SlavecOh+'0  0 < H T`hpxssAleksander Slavecdlek Normal.dotSAleksander Slavecd70kMicrosoft Word 8.0@ P@q@nl@z, 7՜.+,D՜.+,, hp|   vYD   Title 6> _PID_GUIDAN{C32DDAD6-87EB-11D2-A1F5-FE76CD000000}  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHJKLMNOPRSTUVWXZ[\]^_`cRoot EntrygE!\KhC FgN #e1Table|e|eJhCuu0IWordDocumentІp- p- `[`[Lx*SummaryInformation~(PxPxjPQDocumentSummaryInformation8HHYCompObj$y$ghCj\KB\K \K BPSPSr:: BBHagaki Card 8 mmIndex Card 5 x 8 in  FMicrosoft Word Document MSWordDocWord.Document.89qOh+'0  0 < H T`hpxssAleksander Slavecdlek Normal.dotSAleksander Slavecd71kMicrosoft Word 8.0@:SP@q@nl@a 7՜.+,D՜.+,, hp|   vhD   Title 6> _PID_GUIDAN{C32DDAD6-87EB-11D2-A1F5-FE76CD000000}(&P . A!"#$%Accessing address $3FF will ( See Remote IO ) ising edge, falling edge or on both the rising and falling edgeFF BBCBXBCCCCDDDDDDDEGCDDGOJQJhmH nH CJOJQJhnH  [$@$NormalmH H`H Heading 1$@& hCJOJQJhnH B`B Heading 2$@&5B*OJQJhnH 8`8 Heading 3$@& 5CJmH 8`8 Heading 4$@& 5CJmH <A@<Default Paragraph FontJC`JBody Text IndenthB*OJQJhnH RR`RBody Text Indent 2h B*CJhnH C9\U d e f  0 1 X Y `N67?@ BCC%%%%%%%%%%% [!%+C28<Gd OT#(.24569BB3579;>?ACDFG#+,36=G46:=@BEUnknownAleksander SlavecCCCCCCAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec'C:\TEMP\AutoRecovery save of bcm550.asdAleksander Slavec'C:\TEMP\AutoRecovery save of bcm550.asdK ~ n& {ik hho()hho()hho()K{ik~ n&@CChCC777777777777@@yC{CCCC`@a*a>aNaXaw@aw@abaw@adaw@a`x@a`@aa܎@` `@GTimes New Roman5Symbol3& Arial?Times-Roman;"Helvetica"1h+& ,F ,FG? 7v$0dhDAleksander SlavecAleksander SlavecG Gbjbjَ C],,,,,,@$\@$ 2vvvvvvvv       $V Jn7 ,vvvvv7 ,,vv<:v,v,v @@,,,,v . V @,, v<0+xt@@ Root EntrygE!\KhC FgN0+xtz1Table|e|eJhCuu0IWordDocumentІp- p- `[`[LxsSummaryInformation~(PxPxjP   !"#$%&'()*+,-./0123456789:;<=>?@ABCDEiJKLMNOPjhtw{y}~DocumentSummaryInformation8HHCompObj$y$ghCj0Table\K \K BPS: BBHagaki Card 8 mmIndex Card 5 x 8 in  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOD6-87EB-11D2-A1F5-FE76CD000000}Oh+'0  0 < H T`hpxssAleksander Slavecdlek Normal.dotSAleksander Slavecd71kMicrosoft Word 8.0@:SP@q@nl  FMicrosoft Word Document MSWordDocWord.Document.89q՜.+,D՜.+,, hp|   vhD   Title 6> _PID_GUIDAN{C32DDA@a 7 [$@$NormalmH H`H Heading 1$@& hCJOJQJhnH B`B Heading 2$@&5B*OJQJhnH 8`8 Heading 3$@& 5CJmH 8`8 Heading 4$@& 5CJmH <A@<Default Paragraph FontJC`JBody Text IndenthB*OJQJhnH RR`RBody Text Indent 2h B*CJhnH C9\U d e f  0 1 X Y `N67?@ BCC%%%%%%%%%%% [!%+C28<Gd OT#(.24569BB3579;>?ACDFG#+,36=G46:=@BEUnknownAleksander SlavecCCCCCCAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec!D:\Projects\Bcm550\Pcb\bcm550.docAleksander Slavec'C:\TEMP\AutoRecovery save of bcm550.asdAleksander Slavec'C:\TEMP\AutoRecovery save of bcm550.asdK ~ n& {ik hho()hho()hho()K{ik~ n&@CChCC777777777777@@yC{CCCC`@a*a>aNaXaw@aw@abaw@adaw@a`x@a`@aa܎@` `@GTimes New Roman5Symbol3& Arial?Times-Roman;"Helvetica"1h+& ,F ,FG? 7v$0dhDAleksander SlavecAleksander Slavec./version081/bcm550.html0100777000000000000000000000055607300314346013526 0ustar rootroot COLDFORTH KERNEL 
 
: aa ." well well" ;
: aaa 1234 ;
./version081/bcm550.html.bk0100777000000000000000000000056207300314346014116 0ustar rootroot COLDFORTH KERNEL 
 
: aa ." well well" ;
./version081/bcm550.jcc0100777000000000000000000002451407300314346013321 0ustar rootrootjx_browser_data 39 0 "root" 3 1 "New group" 175 2 "_cvs_decode.html" 0 "./_cvs_decode.html" 2 "_do_code.html" 0 "./_do_code.html" 2 "abort.html" 0 "./abort.html" 2 "abort_buffer.png" 0 "./abort_buffer.png" 2 "ansi_code_strict_html.html" 0 "./ansi_code_strict_html.html" 2 "ansi_code_words.html" 0 "./ansi_code_words.html" 2 "ansi_colon_words.html" 0 "./ansi_colon_words.html" 2 "ass.html" 0 "./ass.html" 2 "bank.html" 0 "./bank.html" 2 "bank_bvp5502_code.html" 0 "./bank_bvp5502_code.html" 2 "bank_logon.html" 0 "./bank_logon.html" 2 "bank_memory.html" 0 "./bank_memory.html" 2 "bank_tube.html" 0 "./bank_tube.html" 2 "base_altering.html" 0 "./base_altering.html" 2 "basic_io.html" 0 "./basic_io.html" 2 "bcm522_kernel.mak" 0 "./bcm522_kernel.mak" 2 "bcm522_kernel.mdp" 0 "./bcm522_kernel.mdp" 2 "bcm550.doc" 0 "./bcm550.doc" 2 "bcm550.html" 0 "./bcm550.html" 2 "bcm550.jcc" 0 "./bcm550.jcc" 2 "bcm550_boot_to_ram.html" 0 "./bcm550_boot_to_ram.html" 2 "bcm550_save.html" 0 "./bcm550_save.html" 2 "bcm550_vectors.html" 0 "./bcm550_vectors.html" 2 "buffer_abstract.html" 0 "./buffer_abstract.html" 2 "buffer_paper.html" 0 "./buffer_paper.html" 2 "bugs.txt" 0 "./bugs.txt" 2 "bvp5501_boot_to_ram.html" 0 "./bvp5501_boot_to_ram.html" 2 "bvp5501_constants.html" 0 "./bvp5501_constants.html" 2 "bvp5501_vectors.html" 0 "./bvp5501_vectors.html" 2 "bvp5502_boot_to_ram.html" 0 "./bvp5502_boot_to_ram.html" 2 "bvp5502_constants.html" 0 "./bvp5502_constants.html" 2 "bvp5502_vectors.html" 0 "./bvp5502_vectors.html" 2 "bye_restart_etc.html" 0 "./bye_restart_etc.html" 2 "cache_managment.html" 0 "./cache_managment.html" 2 "cards.html" 0 "./cards.html" 2 "checksum.html" 0 "./checksum.html" 2 "class_data_structure.png" 0 "./class_data_structure.png" 2 "code_words.html" 0 "./code_words.html" 2 "coldfire_opcode.html" 0 "./coldfire_opcode.html" 2 "colon_words.html" 0 "./colon_words.html" 2 "colon_words_used_by_ansi.html" 0 "./colon_words_used_by_ansi.html" 2 "compile.html" 0 "./compile.html" 2 "config.html" 0 "./config.html" 2 "constants.html" 0 "./constants.html" 2 "core" 0 "./core" 2 "date1900.html" 0 "./date1900.html" 2 "digital_interrupt.html" 0 "./digital_interrupt.html" 2 "dma.html" 0 "./dma.html" 2 "double_list.png" 0 "./double_list.png" 2 "dt.html" 0 "./dt.html" 2 "dual_port_memory.html" 0 "./dual_port_memory.html" 2 "editor.html" 0 "./editor.html" 2 "end.4th" 0 "./end.4th" 2 "environment.html" 0 "./environment.html" 2 "ethernet_interrupt.html" 0 "./ethernet_interrupt.html" 2 "fault_data.html" 0 "./fault_data.html" 2 "file_class.html" 0 "./file_class.html" 2 "file_server.html" 0 "./file_server.html" 2 "find.html" 0 "./find.html" 2 "flash.html" 0 "./flash.html" 2 "flash_image.4th" 0 "./flash_image.4th" 2 "flash_write1.png" 0 "./flash_write1.png" 2 "form.html" 0 "./form.html" 2 "forth.css" 0 "./forth.css" 2 "forths_objects.html" 0 "./forths_objects.html" 2 "glossary.html" 0 "./glossary.html" 2 "heap_control.html" 0 "./heap_control.html" 2 "html.html" 0 "./html.html" 2 "htmltags.4th" 0 "./htmltags.4th" 2 "ibm.html" 0 "./ibm.html" 2 "if_then_else.html" 0 "./if_then_else.html" 2 "ilan_temp.html" 0 "./ilan_temp.html" 2 "imond.pl" 0 "./imond.pl" 2 "index.html" 0 "./index.html" 2 "initial_abort.html" 0 "./initial_abort.html" 2 "inode.html" 0 "./inode.html" 2 "input_output.html" 0 "./input_output.html" 2 "parser.html" 0 "./parser.html" 2 "interrupt_colon.html" 0 "./interrupt_colon.html" 2 "interrupt_stack.png" 0 "./interrupt_stack.png" 2 "io_common.html" 0 "./io_common.html" 2 "ip_intro.html" 0 "./ip_intro.html" 2 "joining_buffer.png" 0 "./joining_buffer.png" 2 "kernel.bin" 0 "./kernel.bin" 2 "kernel.html" 0 "./kernel.html" 2 "kernel_comp.4th" 0 "./kernel_comp.4th" 2 "kernel_tasks.html" 0 "./kernel_tasks.html" 2 "license.html" 0 "./license.html" 2 "linence.html" 0 "./linence.html" 2 "link_lists.html" 0 "./link_lists.html" 2 "linked_object.html" 0 "./linked_object.html" 2 "linux_save.html" 0 "./linux_save.html" 2 "linux_save.html~" 0 "./linux_save.html~" 2 "local_data.png" 0 "./local_data.png" 2 "local_variables.html" 0 "./local_variables.html" 2 "locals.html" 0 "./locals.html" 2 "locate.html" 0 "./locate.html" 2 "mac_use.html" 0 "./mac_use.html" 2 "make.doc" 0 "./make.doc" 2 "Make.files" 0 "./Make.files" 2 "Make.header" 0 "./Make.header" 2 "marker.html" 0 "./marker.html" 2 "maths_functions.4th" 0 "./maths_functions.4th" 2 "maths_functions1.4th" 0 "./maths_functions1.4th" 2 "mcf5307_init.html" 0 "./mcf5307_init.html" 2 "memory_allocation.html" 0 "./memory_allocation.html" 2 "more_ansi_colon_words.html" 0 "./more_ansi_colon_words.html" 2 "more_forth.html" 0 "./more_forth.html" 2 "multitasking_abstract.html" 0 "./multitasking_abstract.html" 2 "multitasking_paper.html" 0 "./multitasking_paper.html" 2 "nice_setup.html" 0 "./nice_setup.html" 2 "number.html" 0 "./number.html" 2 "number_output.html" 0 "./number_output.html" 2 "object_linked_list.html" 0 "./object_linked_list.html" 2 "objects.html" 0 "./objects.html" 2 "op_function_vectors.html" 0 "./op_function_vectors.html" 2 "operator_task_table.html" 0 "./operator_task_table.html" 2 "panic0.html" 0 "./panic0.html" 2 "panic1.html" 0 "./panic1.html" 2 "parented_object.html" 0 "./parented_object.html" 2 "pipe.html" 0 "./pipe.html" 2 "port_tube.html" 0 "./port_tube.html" 2 "print_source.html" 0 "./print_source.html" 2 "print_system_data.html" 0 "./print_system_data.html" 2 "printing.html" 0 "./printing.html" 2 "prompt.html" 0 "./prompt.html" 2 "queue.html" 0 "./queue.html" 2 "quit_interpret_etc.html" 0 "./quit_interpret_etc.html" 2 "ramp.png" 0 "./ramp.png" 2 "ramp4.png" 0 "./ramp4.png" 2 "real_numbers.html" 0 "./real_numbers.html" 2 "real_time_clock.html" 0 "./real_time_clock.html" 2 "resource.h" 0 "./resource.h" 2 "rlogon.html" 0 "./rlogon.html" 2 "root.html" 0 "./root.html" 2 "rti.html" 0 "./rti.html" 2 "rti1000_interrupt.html" 0 "./rti1000_interrupt.html" 2 "save_image.html" 0 "./save_image.html" 2 "script1.rc" 0 "./script1.rc" 2 "scsi.html" 0 "./scsi.html" 2 "selector.png" 0 "./selector.png" 2 "setup_xcom.html" 0 "./setup_xcom.html" 2 "show.html" 0 "./show.html" 2 "small_buffer.png" 0 "./small_buffer.png" 2 "start_application_dict.html" 0 "./start_application_dict.html" 2 "string_literals.html" 0 "./string_literals.html" 2 "struct.html" 0 "./struct.html" 2 "system_rte.html" 0 "./system_rte.html" 2 "system_stack.png" 0 "./system_stack.png" 2 "task_loop.png" 0 "./task_loop.png" 2 "task_loops.html" 0 "./task_loops.html" 2 "task_stuff.html" 0 "./task_stuff.html" 2 "tasking.png" 0 "./tasking.png" 2 "tcp_test.4th" 0 "./tcp_test.4th" 2 "terminal_class.html" 0 "./terminal_class.html" 2 "test1.html" 0 "./test1.html" 2 "to_do.html" 0 "./to_do.html" 2 "traps.html" 0 "./traps.html" 2 "tube.html" 0 "./tube.html" 2 "tyx.html" 0 "./tyx.html" 2 "user_using_words.html" 0 "./user_using_words.html" 2 "user_variables.html" 0 "./user_variables.html" 2 "version.html" 0 "./version.html" 2 "vocabulary.html" 0 "./vocabulary.html" 2 "vocabulary.png" 0 "./vocabulary.png" 2 "watchdog.html" 0 "./watchdog.html" 2 "word.html" 0 "./word.html" 2 "word_head.html" 0 "./word_head.html" 2 "wordlists.html" 0 "./wordlists.html" 2 "words.html" 0 "./words.html" 2 "words_using_heap.html" 0 "./words_using_heap.html" 2 "ws60.html" 0 "./ws60.html" 2 "xcom.html" 0 "./xcom.html" 2 "xcomp2.4th" 0 "./xcomp2.4th" 2 "xwords.html" 0 "./xwords.html" 1 "New group" 40 2 "arp_entry.png" 0 "./tcp/arp_entry.png" 2 "demux.html" 0 "./tcp/demux.html" 2 "demux_socket.html" 0 "./tcp/demux_socket.html" 2 "echo.html" 0 "./tcp/echo.html" 2 "ethernet_h.html" 0 "./tcp/ethernet_h.html" 2 "fragment.png" 0 "./tcp/fragment.png" 2 "html.html" 0 "./tcp/html.html" 2 "icmp_demux.html" 0 "./tcp/icmp_demux.html" 2 "icmp_echo.html" 0 "./tcp/icmp_echo.html" 2 "icmp_h.html" 0 "./tcp/icmp_h.html" 2 "interface_common.html" 0 "./tcp/interface_common.html" 2 "interface_local.html" 0 "./tcp/interface_local.html" 2 "interface_loopback.html" 0 "./tcp/interface_loopback.html" 2 "interface_nice.html" 0 "./tcp/interface_nice.html" 2 "io_protocol_common.html" 0 "./tcp/io_protocol_common.html" 2 "ip_packet_flow.png" 0 "./tcp/ip_packet_flow.png" 2 "ip_setup.html" 0 "./tcp/ip_setup.html" 2 "nfs.html" 0 "./tcp/nfs.html" 2 "overview.html" 0 "./tcp/overview.html" 2 "pep.png" 0 "./tcp/pep.png" 2 "pep_h.html" 0 "./tcp/pep_h.html" 2 "port_mapper_client.html" 0 "./tcp/port_mapper_client.html" 2 "print_pep.html" 0 "./tcp/print_pep.html" 2 "proto.html" 0 "./tcp/proto.html" 2 "routing.html" 0 "./tcp/routing.html" 2 "routing_h.html" 0 "./tcp/routing_h.html" 2 "rpc.html" 0 "./tcp/rpc.html" 2 "sort_key.png" 0 "./tcp/sort_key.png" 2 "system_stack.png" 0 "./tcp/system_stack.png" 2 "tcp.html" 0 "./tcp/tcp.html" 2 "tcp_demux.html" 0 "./tcp/tcp_demux.html" 2 "tcp_diag2.png" 0 "./tcp/tcp_diag2.png" 2 "tcp_h.html" 0 "./tcp/tcp_h.html" 2 "tcp_rcv_win.png" 0 "./tcp/tcp_rcv_win.png" 2 "tcp_snd_win.png" 0 "./tcp/tcp_snd_win.png" 2 "telnet_server.html" 0 "./tcp/telnet_server.html" 2 "temp.html" 0 "./tcp/temp.html" 2 "timestamp.html" 0 "./tcp/timestamp.html" 2 "udp.html" 0 "./tcp/udp.html" 2 "udp_demux.html" 0 "./tcp/udp_demux.html" 1 "New group" 8 2 "bvp5551_boot_to_ram.html" 0 "./bvp5551_boot_to_ram.html" 2 "bvp5551_constants.html" 0 "./bvp5551_constants.html" 2 "bvp5551_vectors.html" 0 "./bvp5551_vectors.html" 2 "bvp5552_boot_to_ram.html" 0 "./bvp5552_boot_to_ram.html" 2 "bvp5552_constants.html" 0 "./bvp5552_constants.html" 2 "bvp5552_vectors.html" 0 "./bvp5552_vectors.html" 2 "bank_bvp5552_code.html" 0 "./bank_bvp5552_code.html" 2 "bvp5552bank_memory.html" 0 "./bvp5552bank_memory.html" 0 458 23 550 550 F 3 T T T 0 T 1 0 0 1 878 0 T T "a.out" "/home/charlese/bcm550/56/" "" "" 0 0 0 170 450 F 0 F 0 "" 10000 0 "" 10000 0 0 0 T T T F 0 0 0 5 ".h" ".H" ".hh" ".hpp" ".hxx" 0 0 0 0 400 430 F 0 T 1 0 0 1 0 0 0 337 139 350 350 F "./" 10000 0 "makemake" 10000 1 "makemake" "" F "make -k" 10000 1 "make -k" "" "make $r" 10000 2 "make $r" "" "make CHECKSTRING=$n checksyntax" "" T T "/home/charlese/bcm550/53/" 956142852 956142852 0 337 166 350 270 F "./" 10000 0 "a.out" 10000 1 "a.out" "" "medic -f +$l $f" 10000 1 "medic -f +$l $f" "" T T 3 0 "" "lpr" F4 "" 0 0 F 00 "" F F 3 0 "" "lpr" F4 "" 0 0 F F 0 5 T "/home/charlese/bcm550/56/tcp/rpc.html" "" "" 0 462 0 550 550 F 18788 0 T 1 0 0 1 9496 0 F T "/home/charlese/bcm550/56/tcp/udp.html" "" "" 0 53 43 643 550 F 5750 0 T 1 0 0 1 2729 0 T "/home/charlese/bcm550/56/fault_data.html" "" "" 0 435 42 550 550 F 6649 0 T 1 0 0 1 2762 0 T "/home/charlese/bcm550/56/tcp/nfs.html" "" "" 0 231 95 550 550 F 1329 0 T 1 0 0 1 464 0./version081/bcm550h_constants.html0100777000000000000000000016442107300314346015774 0ustar rootroot COLDFORTH KERNEL license

Base for baud rate and timer calculations. 

 
	#45000000 CONSTANT _#bus_clock

BCM550 Memory map

Very early in the startup routine we test the dynamic ram. To have this happen in a resonable time the boot prom needs to be cached. The minimum cache size is 16 meg. So the boot prom is mapped into a 16 meg region at the start of memory. The rest of the memory areas follow from there.

From To Size Comment
0x00000000 0x07FFFF 0x80000 Boot prom
0x01000000 0x1FFFFF 0x200000 Application flash
0x02400000 0x00FFFF 0x4000 dual port memory
0x02600000 0x00FFFF 0x10000 Ethernet Controller
0x02800000 0x00FFFF 0x00400 Remote i/o
0x02A00000 0x0FFFFF 0100000 RTI Bus
0x02C00000 0x07FFFF 0x80000 Copy boot flash
0x02E00000 0x00FFFF 0x10000 function see additional table
0x03000000 0x0F00FFF0x1000 Modules base address register, any 4kbyte boundry
0x03080000 0x0F00FFF0x1000 Internal ram
0x100000000x10FFFFFF0x1000000DRAM1
0x110000000x11FFFFFF0x1000000DRAM2

Chip select 0, boot flash

 
	.S .( start MCF5307_constants.html)
	$00000000 CONSTANT _#boot_flash_base
	$00080000 CONSTANT _#boot_flash_size

Chip select 1, application flash

 
	$01000000 CONSTANT _#application_flash_base
	$00200000 CONSTANT _#application_flash_size

Chip select 2 -> 7

 
	$02000000 CONSTANT _#csbar  \ chip select base address register value

Chip select 2, RTI1000 dual port memory

 
	$00400000 _#csbar + CONSTANT _#RTI1000_dual_port_base
	$00004000           CONSTANT _#RTI1000_dual_port_size

Chip select 3, Ethernet controller

 
	$00600000 _#csbar + CONSTANT _#ethernet_controller_base
	$00010000           CONSTANT _#ethernet_controller_size

Chip select 4, Remote IO

 
	$00800000 _#csbar + CONSTANT _#remote_i/o_base
	$00000400           CONSTANT _#remote_i/o_size

Chip select 5, RTI1000 bus

 
	$00A00000 _#csbar + CONSTANT _#RTI1000_bus_base
	$00100000           CONSTANT _#RTI1000_bus_size

Chip select 6, Boot copy flash

 
	$00C00000 _#csbar + CONSTANT _#copy_boot_flash_base
	$00080000           CONSTANT _#copy_boot_flash_size

Chip select 7, function data

 
	$00E00000 _#csbar + CONSTANT _#function_data_base
	$00000040           CONSTANT _#function_data_size

Dynamic memory

 
	_prom_kernel_start CONSTANT _#sdram0_base
	$01000000 CONSTANT _#sdram0_size 
	$11000000 CONSTANT _#sdram1_base
	$01000000 CONSTANT _#sdram1_size

	_#sdram0_base CONSTANT _#start_dynamic
	$12000000 CONSTANT _#end_dynamic	
.S .( after _#end_dynamic)

MBAR

MBAR ( Module Base Address Register) is set with the code: 

 
#mba _#mbar_valid_bit + #  D0   MOV
D0      MBAR MOV

Once the MBA is set the registers are located in a specific spot in memory. 

 
	$03000000 CONSTANT #mba
		\ set to zero on a reset, must be set to one for access
		\ to system integration module
		$00000001 CONSTANT _#mbar_valid_bit

		\ every address has an address modifier associated 
		\ with it. Setting the following bits [revent access
		\ to the system modules in particular address spaces.
		\ In this sytem access is allowed in all spaces.
		$00000002 CONSTANT _#mbar_block_user_data
		$00000004 CONSTANT _#mbar_block_user_code
		$00000008 CONSTANT _#mbar_block_system_data
		$00000010 CONSTANT _#mbar_block_system_code
		$00000020 CONSTANT _#mbar_block_c/i
		$00000040 CONSTANT _#mbar_allow_alternate

RAMBAR

Base address of the on board static ram. Set with the instruction:

 
D0 RAMBAR MOV

Section 6.3.4 talks about reducing power consumption, in our case the on board ram is not used for code so we block code accesses 

 
	$03080000           CONSTANT _#rambar_base     \ coldfire ram
		$00000001 CONSTANT _#rambar_valid
		$00000002 CONSTANT _#rambar_block_user_data
		$00000004 CONSTANT _#rambar_block_user_code
		$00000008 CONSTANT _#rambar_block_system_data
		$00000010 CONSTANT _#rambar_block_system_code
		$00000020 CONSTANT _#rambar_block_c/i
		$00000100 CONSTANT _#rambar_write_protect

	$1000 CONSTANT _#rambar_size

CACHE

The memory space can be divided up into three modes. This system has a lot of memory areas devoted to I/O, the default mode shall be suitable for that type of operation. That is non-cachable. Imprecise is the default mode. If a location access resets an interrupt it must be written to. Read imprecise mode allows multiple reads under some circumstances. Oh how I wish for the simple days, when computers did what they where told.

CACR ( Cache Control register) 

 
	$80000000 CONSTANT _#cacr_EC    \ Enable cache
\	$20000000 CONSTANT _#cacr_ESB   \ We don't enable the store buffer, there is no code
	                               \ in non cachable areas
\	$10000000 CONSTANT _#cacr_DPI   \ Disable CPUSHL invalidate. Don't use the instruction
	                               \ don't care
\	$08000000 CONSTANT _#cacr_HLCK  \ don't use.
	$01000000 CONSTANT _#cacr_CINVA \ cache invalidate all, needed to get started
\	$00000400 CONSTANT _#cacr_DNFB  \ All code is cached
	$00000300 CONSTANT _#cacr_DCM   \ Default cache mode, cache-inhibited,imprecise 
\	$00000001 CONSTANT _#cacr_DW    \ write is allowed

ACR0

 
	_#sdram0_base CONSTANT _#acr0_address_base
	_#sdram0_size 1 - $FF000000 AND 8 RSHIFT CONSTANT _#acr0_address_mask \ will be zero
	$8000  CONSTANT _#acr0_enable
	$6000  CONSTANT _#acr0_SFIELD \ ignore FC2 when matching
	$0020  CONSTANT _#acr0_CM     \ cachable, copyback

ACR1

 
	_#boot_flash_base CONSTANT _#acr1_address_base
	_#boot_flash_size 1 - $FF000000 AND 8 RSHIFT CONSTANT _#acr1_address_mask \ will be zero
	$8000  CONSTANT _#acr1_enable
	$6000  CONSTANT _#acr1_SFIELD \ ignore FC2 when matching
	$0020  CONSTANT _#acr1_CM     \ cachable, copyback

System integration module

Describe the 5307 memory map in byte offsets. Names are taken from the 5307 users manual, but are preceeded with a size code.
b = byte
w = word
l = long

See section 8 of the users manual

reset status register

Read only register. Read if you want to find out reset reason. 

 
	$000	#mba + CONSTANT _breg_RSR
		$80 CONSTANT _#rst_hard_reset
		$20 CONSTANT _#rst_soft_reset

System protection control register

 
	$001 #mba + CONSTANT _breg_SYPCR
		\ ### set to $80 when cards with new mask arrive
		$00 CONSTANT _#sypcr_watchdog_enable
		$40 CONSTANT _#sypcr_timeout_enable_reset
		$20 CONSTANT _#sypcr_prescale \ clock divided by 8192
		\ prescale = 0
		\ 00 = 2**9 01 = 2**11 10 = 2**13 11 = 2**15
		\ prescale = 1
		\ 00 = 2**22 01 = 2**24 10 = 2**26 ( aprox 1 sec) 11 = 2**28 ( aprox 4 sec)
		$18 CONSTANT _#sypcr_swt



	\ software watchdog interrupt vector register
	$002 #mba + CONSTANT _breg_SWIVR
	\ Software watchdog service register
	$003 #mba + CONSTANT _breg_SWSR
	\ Pin assignment register
	\ see section 10 of the users manual see also
	\ _wreg_PADDR and _wreg_PADAT
	$004 #mba + CONSTANT _wreg_PAR
	\ Interrupt assignment register
	$006 #mba + CONSTANT _breg_IRQPAR
	\ PLL control register
	$008 #mba + CONSTANT _breg_PLLCR
		$80 CONSTANT _#pllcr_ENBSTOP  \ enable stop
		07 4 LSHIFT  CONSTANT _#pllcr_PLLIPL 
	\ master bus control register
	$00C #mba + CONSTANT _breg_MPARP
		$20 CONSTANT _#mpark_IARBCTRL
		$10 CONSTANT _#mpark_EARBCTRL
		$08 CONSTANT _#mpark_SHOWDATA

Interrupt controller

See section 8.3.3 of the user manual

Interrupt source
source AVECLevelIPVectorcomment
SWT 0 7(1) 0040
Timer 1 1 6(2) 001E 10 msec
Timer 2 1 5(3) 111D Watchdog
MBUS 1 4(5) 111C Not used
UART1 0 6(4) 1160
UART2 0 6 1061
DMA0 0 2 1162 Ethernet
DMA1 0 2 1063 User
DMA2 0 2 0164 Uart0
DMA3 0 2 0065 Uart1
reserved1 3 101B
reserved1 3 011B
EINT7 1 7(1) - 1F Bus error
EINT6- - - -
EINT50 5 - 80->8FRTI1000 bus
EINT4- - - -
EINT3-a0 3(6) - 90 Digital1
EINT3-b" " - 91 Digital2
EINT3-c" " - 92 RTI-Aclow
EINT3-d" " - 93 RTI-Sysfail
EINT3-e" " - 94 Remote_I/O
EINT20 - - -
EINT11 1 - 19 ethernet
(1)SWT doesn't work, buss error is generated by card. Both have to be on level 7. SWT is vectored, external bus error is autovectored
(2)Multitasker still has clock tasks at lowest priority. Clock interrupt routine can be on any level. We put it on highest so 10msec interrupts are not lost.
(3)Placed on level 5 as the external inturrupt vectors leaving the auto vector free for the second timer.
(4)All level 6 interrupts are vectored. (5)MBUS only autovectored. (6)Level three used for system interrups, autovector not used.

Interrupt pending register

A read only register 

 
	$040 #mba + CONSTANT _lreg_IPR

Interrupt mask register

You set a bit to disable the interrupt. 

 
	$044 #mba + CONSTANT _lreg_IMR
		$20000 CONSTANT _#imr_DMA3
		$10000 CONSTANT _#imr_DMA2
		$08000 CONSTANT _#imr_DMA1
		$04000 CONSTANT _#imr_DMA0
		$02000 CONSTANT _#imr_UART2
		$01000 CONSTANT _#imr_UART1
		$00800 CONSTANT _#imr_MBUS
		$00400 CONSTANT _#imr_TIMER2
		$00200 CONSTANT _#imr_TIMER1
		$00100 CONSTANT _#imr_SWT
		$00080 CONSTANT _#imr_EINT7
		$00040 CONSTANT _#imr_EINT6
		$00020 CONSTANT _#imr_EINT5
		$00010 CONSTANT _#imr_EINT4
		$00008 CONSTANT _#imr_EINT3
		$00004 CONSTANT _#imr_EINT2
		$00002 CONSTANT _#imr_EINT1

Autovector control_register

Set to true if the external interrupt is to be auto vectored. In our case external interrupt 1 has to be autovectored, all others are vectored. We don't need an external AS on AVEC. 

 
	$04B #mba + CONSTANT _breg_AVCR
		$80 CONSTANT _#avec_AVEC7
		$40 CONSTANT _#avec_AVEC6
		$20 CONSTANT _#avec_AVEC5
		$10 CONSTANT _#avec_AVEC4
		$08 CONSTANT _#avec_AVEC3
		$04 CONSTANT _#avec_AVEC2
		$02 CONSTANT _#avec_AVEC1
		$01 CONSTANT _#avec_BLK

Interrupt control register 0

SWT, not working at the moment. See section 8.3.4 

 
	$04C #mba + CONSTANT _breg_ICR0
		$00 CONSTANT _#icr0_AVEC
		$07 2 LSHIFT CONSTANT _#icr0_IL
		$00 CONSTANT _#icr0_IP

Interrupt control register 1

TIMER 1 

 
	$04D #mba + CONSTANT _breg_ICR1
		$80 CONSTANT _#icr1_AVEC
		$06 2 LSHIFT CONSTANT _#icr1_IL
		$03 CONSTANT _#icr1_IP

Interrupt control register 2

TIMER 2 

 
	$04E #mba + CONSTANT _breg_ICR2
		$80 CONSTANT _#icr2_AVEC
		$05 2 LSHIFT CONSTANT _#icr2_IL
		$03 CONSTANT _#icr2_IP

Interrupt control register 3

MBUS 

 
	$04F #mba + CONSTANT _breg_ICR3
		$00 CONSTANT _#icr3_AVEC
		$04 2 LSHIFT CONSTANT _#icr3_IL
		$03 CONSTANT _#icr3_IP

Interrupt control register 4

Uart 1 

 
	$050 #mba + CONSTANT _breg_ICR4
		$00 CONSTANT _#icr4_AVEC
		$06 2 LSHIFT CONSTANT _#icr4_IL
		$00 CONSTANT _#icr4_IP

Interrupt control register 5

Uart 2 

 
	$051 #mba + CONSTANT _breg_ICR5
		$00 CONSTANT _#icr5_AVEC
		$06 2 LSHIFT CONSTANT _#icr5_IL
		$03 CONSTANT _#icr5_IP

Interrupt control register 6

DMA0 

 
	$052 #mba + CONSTANT _breg_ICR6
		$00 CONSTANT _#icr6_AVEC
		$02 2 LSHIFT CONSTANT _#icr6_IL
		$03 CONSTANT _#icr6_IP

Interrupt control register 7

DMA1 

 
	$053 #mba + CONSTANT _breg_ICR7
		$00 CONSTANT _#icr7_AVEC
		$02 2 LSHIFT CONSTANT _#icr7_IL
		$02 CONSTANT _#icr7_IP

Interrupt control register 8

DMA2 

 
	$054 #mba + CONSTANT _breg_ICR8
		$00 CONSTANT _#icr8_AVEC
		$02 2 LSHIFT CONSTANT _#icr8_IL
		$01 CONSTANT _#icr8_IP

Interrupt control register 9

DMA3 

 
	\ Interrupt control register 9
	$055 #mba + CONSTANT _breg_ICR9
		$00 CONSTANT _#icr9_AVEC
		$02 2 LSHIFT CONSTANT _#icr9_IL
		$00 CONSTANT _#icr9_IP

Interrupt control register 10

Reserved 

 
	\ Interrupt control register 10
	$056 #mba + CONSTANT _breg_ICR10
		$80 CONSTANT _#icr10_AVEC
		$03 2 LSHIFT CONSTANT _#icr10_IL
		$01 CONSTANT _#icr10_IP

Interrupt control register 11

Reserved 

 
	\ Interrupt control register 11
	$057 #mba + CONSTANT _breg_ICR11
		$80 CONSTANT _#icr11_AVEC
		$03 2 LSHIFT CONSTANT _#icr11_IL
		$00 CONSTANT _#icr11_IP

Chip select module

See section 9 of the users manual

CHIP-SELECT ADDRESS REGISTER (CSAR0, CSAR1 AND CSBAR)

Each CSARx and CSBAR determines the base address of the corresponding chip-select pin. CSAR0 and CSAR1 determine the base addresses from which chip-selects 0 and 1 will be offset, respectively. CSBAR determines the base address from which chip-selects 2 through 7 will be offset.

CSAR0 and CSAR1 are 16-bit read/write registers.
CSBAR is a 8-bit read/write register.
The value stored in each CSAR register corresponds to A[31:16]. The value stored in the CSBAR register corresponds to A[31:24].
CSAR0, CSAR1 and CSBAR are uninitialized by reset 

 
	\ Chip select address register bank0
	$080 #mba + CONSTANT _wreg_CSAR0

Chip Select Mask Register ( CSMR0 -> CSMR7 )

BitNameComment
31->16 BAM - Base address mask This field defines the chip-select block size through the use of address mask bits. Any set bit masks the corresponding base address register (CSAR) bit (the base address bit becomes a dont care in the decode). 0 = Corresponding address bit is used in chip select decode 1 = Corresponding address bit is a dont care in chip select decode
15->9Reserved
8WP - Write protect The WP bit can restrict write accesses to the address range in a CSAR. An attempt to write to the range of addresses specified in a CSAR that has this bit set will result in the appropriate chip-select not being selected. 1 = Only read accesses are allowed 0 = Either read or write accesses are allowed
6AM - alternate master When AM=0 and an alternate master access occurs, SC, SD, UC, and UD are dont cares in the chip-select decode.
5C/I = CPU space and Interrupt Acknowledge Cycle mask CS0, CS1, and CS7 only. Set to one to mask out.
4SC = Supervisor Code address space maskSet to one to mask out.
3SD = Supervisor Data address space maskSet to one to mask out.
2UC = User Code address space maskSet to one to mask out.
1UD = User Data address space maskSet to one to mask out.
4V - Valid bit The Valid bit indicates that the contents of its address register, mask register, and control register are valid. The programmed chip selects do not assert until the V-bit is set (except for CS0 which acts as the global (boot) chip select. 
 
	\ chip select mask register bank0
	$084 #mba + CONSTANT _lreg_CSMR0
		$00100 CONSTANT _#csmrx_WP  \ write protect
		$00040 CONSTANT _#csmrx_AM  \ alternate master
		$00020 CONSTANT _#csmrx_C/I \ No cpu/iack select 1,2 and 7
		$00010 CONSTANT _#csmrx_SC  \ supervisor code
		$00008 CONSTANT _#csmrx_SD  \ supervisor data
		$00004 CONSTANT _#csmrx_UC  \ User code
		$00002 CONSTANT _#csmrx_UD  \ User data
		$00001 CONSTANT _#csmrx_V   \ valid bit.

CHIP-SELECT CONTROL REGISTER (CSCR0 - CSCR7).

Each CSCR controls the auto acknowledge, external master support, port size, burst capability, and activation of each of the chip-selects.

Chip Select Control Register(CSCR0-7)
BitNameComment
15,14Reserved
13->10WS - Wait States This field defines the number of wait states that will be inserted before an internal transfer acknowledge is generated. If the AA bit is set to 0, TA is asserted by the external system regardless of the number of wait states generated. In that case the external transfer acknowledge will end the cycle.
8AA - Auto-Acknowledge Enable This field controls the assertion of the internal transfer-acknowledge during all accesses that hit in the corresponding chip-select address space. If AA=1, the internal transfer-acknowledge will be asserted at the time determined by the value of WS[3:0]. If AA=0, the Chip-Select Module will not cause the internal transfer acknowledge to be asserted and the cycle will have to be terminated by the external system.
7,6PS - Port Size This field specifies the width of the data associated with each chip-select. It determines where data will be driven during write cycles and where data will be sampled during read cycles.
00 = 32-bit port size - Data sampled and driven on D[31:0]
01 = 8-bit port size - Data sampled and driven on D[31:24] only
10 = 16-bit port size - Data sampled and driven on D[31:16] only
11 = 16-bit port size - Data sampled and driven on D[31:16] only
4BSTR - Burst Read Enable This field specifies the read burst capability of the memory associated with each chip- select. If BSTR=1, all reads from port sizes smaller than the requested transfer size will be bursted, including longword reads from 8 and 16-bit ports, word reads from 8-bit ports as well as line reads from 8-, 16-, and 32-bit ports. If BSTR=0, all reads from port sizes smaller than the requested transfer size will be broken into individual reads that are no larger than the specified port size. For example, a longword read from an 8-bit port would be broken into four individual byte reads. 0 = Break all reads that are larger than the specified port size into individual nonburst reads that are no larger than the specified port size
3BSTW - Burst Write Enable This field specifies the write burst capability of the memory associated with each chip-select. If BSTW=1, all writes to port sizes smaller than the requested transfer size will be bursted, including longword writes to 8 and 16-bit ports, word writes to 8-bit ports as well as line writes to 8-, 16-, and 32-bit ports. If BSTW=0, all writes to port sizes smaller than the requested transfer size will be broken into individual writes that are no larger than the specified port size. For example, a longword write to an 8-bit port would be broken into four individual byte writes.
3BEM - Byte Enable Module This field specifies the mode of functionality for byte enables. Certain SRAMs have byte enables that must be asserted during reads (in addition to writes.) The BEM bit may be set in the relevant CSCR to provide the appropriate mode of byte enable in support of these SRAMS. The default mode after reset is 0 for CS7 - CS1 and 1 for CS0.
1 = BE/BWE signals generated for data reads and writes
0 = BWE signals generated for data writes only
 
	\ chip select control register bank0
	\ Boot flash
	$08A #mba + CONSTANT _wreg_CSCR0
		$2000 CONSTANT _#cscr0_wait_states \ eight wait states
		$0100 CONSTANT _#cscrx_AA   \ auto acknowledge
		$0040 CONSTANT _#cscr0_port_size   \ 8 bit
		$0020 CONSTANT _#cscrx_BEM  \ Byte enable module
		$0010 CONSTANT _#cscrx_BSTR \ Burst read enable
		$0008 CONSTANT _#cscrx_BSWE \ Burst write enable 

	\ Chip select address register bank1
	\ Application flash
	$08C #mba + CONSTANT _wreg_CSAR1
	\ chip select mask register bank1
	$090 #mba + CONSTANT _lreg_CSMR1
	\ chip select control register bank1
	$096 #mba + CONSTANT _wreg_CSCR1
		$1800 CONSTANT _#cscr1_wait_states \ six wait states
		$0080 CONSTANT _#cscr1_port_size \ 16 bit

	\ Chip select address register bank2
	\ RTI1000 dual port memeory
	$098 #mba + CONSTANT _wreg_CSAR2
	\ pre 00J20C mask
	$098 #mba + CONSTANT _breg_CSBAR
	\ chip select mask register bank2
	$09C #mba + CONSTANT _lreg_CSMR2
	\ chip select control register bank2
	$0A2 #mba + CONSTANT _wreg_CSCR2
		$0C00 CONSTANT _#cscr2_wait_states \ three wait states
		$0080 CONSTANT _#cscr2_port_size   \ 16 bit

	\ Chip select address register bank3
	\ Ethernet controller
	$0A4 #mba + CONSTANT _wreg_CSAR3
	\ chip select mask register bank3
	$0AA #mba + CONSTANT _wreg_CSMR3
	\ chip select control register bank3
	$0AE #mba + CONSTANT _wreg_CSCR3
			$0080 CONSTANT _#cscr3_port_size \ 16 bit


	\ Chip select address register bank4
	\ Remote I/O dual port memory
	$0B0 #mba + CONSTANT _wreg_CSAR4
	\ chip select mask register bank4
	$0B6 #mba + CONSTANT _wreg_CSMR4
	\ chip select control register bank4
	$0BA #mba + CONSTANT _wreg_CSCR4
		$1800 CONSTANT _#cscr4_wait_states \ six wait states
		$0040 CONSTANT _#cscr4_port_size \ 08 bit

	\ Chip select address register bank5
	\ RTI1000 bus
	\ Auto acknowledge is not used.
	$0BC #mba + CONSTANT _wreg_CSAR5
	\ chip select mask register bank5
	$0C2 #mba + CONSTANT _wreg_CSMR5
	\ chip select control register bank5
	$0C6 #mba + CONSTANT _wreg_CSCR5
		$0080 CONSTANT _#cscr5_port_size \ 16 bit

	\ Chip select address register bank6
	\ Boot copy flash
	$0C8 #mba + CONSTANT _wreg_CSAR6
	\ chip select mask register bank6
	$0CE #mba + CONSTANT _wreg_CSMR6
	\ chip select control register bank6
	$0D2 #mba + CONSTANT _wreg_CSCR6
		$1800 CONSTANT _#cscr6_wait_states \ six wait states
		$0040 CONSTANT _#cscr6_port_size \ 08 bit

	\ Chip select address register bank7
	\ System control registers.
	$0D4 #mba + CONSTANT _wreg_CSAR7
	\ chip select mask register bank7
	$0DA #mba + CONSTANT _wreg_CSMR7
	\ chip select control register bank7
	$0DE #mba + CONSTANT _wreg_CSCR7
		$0C00 CONSTANT _#cscr7_wait_states \ one wait states
		$0040 CONSTANT _#cscr7_port_size   \ 08 bit
.S .( after _#cscr7_port_size)

DRAM controller

See section 11 of the users manual

Address mutiplexing

Address Muxing Scheme (32 bit)
Sdram Address PinColdfire Address PinROW ADDRESSCOLUMN ADDRESS
16161
A015152 used
A114143 used
A213134 used
A312125 used
A411116 used
A510107 used
A6998 used
A7171716 used
A8181817
A9191918
A11202019
A10(precharge command)212120
BA0222221
BA1232322
242423
252524

We are using two 1Meg*16*4 per bank.

Memory chips with a page size below 512 byts are not supported. Chips with a page size greater than 512 bytes will have the page split up and placed all over tha place.

In our arrangment each chip has a page size of 512 bytes but two are used to give us a 32 bit wide data path resulting in a page size of 1024 bytes.

In our example the additional bit multiplexed with the column addess is address bit 16. So the second half of the sdram memory page is found 64k away in the coldfire memory map.

The generation of the required row address is the problem of the memory controller. So the net effect is a few more row address generations when long data structures are being delt with.

We have a 32 bit data path, we therfore don't need address bits 0 and 1 in the column address. Looking at the above table we need coldfire address pin 15 connected to the sdram address pin 0, coldfire address pin 14 to sdram address pin 1 and so on until address pin 9. This deal with address bits 2 to 15. Coldfire address pins 17 to 21 are then connected to the sdram address pins 7 to 11, this deals with address bits 16 ( as part of the column address) to 21. Coldfire address pins 20 and 21 are used as the bank selects.

There is one small complication. In 32 bit mode coldfire address A21 has the precharge command on it, this must be connected to sdram adress pin 10.

DRAM control register ( DCR )

bitnameCommentBCM550
15SO - Synchronous Operation This bit determines if the SADRAMC is in synchronous operation mode. For synchronous DRAMs, this bit must be set to one. Note that once the part has entered into synchronous operation, it cannot be returned to asynchronous operation except by a reset. 1
14
Reserved0
13NAM - No Address Multiplexing Some implementations will require external multiplexing support. For instance, if there is an external master accessing the DRAM or if a linear addressing scheme is required the SADRAMC multiplexing may not be sufficient. In these cases, it would be advantageous to prevent the SADRAMC from multiplexing the addresses on a DRAM access. If this bit is set to a 1, the SADRAMC will not multiplex the external address bus to provide column addresses.0
12COC - Command On Clock enable Implementations that utilize external multiplexing must have support for command information to be multiplexed onto the SDRAM address bus. This bit allows the command information to be driven out on what is normally the SDRAM clock enable (SCKE). In this case, the SADRAMC will not support self refresh operation, but external support may be generated. If the COC bit is set, the address command bit information will be generated on the SCKE pin. External multiplexing will be responsible for putting the command information on the proper address bit.0
11IS - Initiate Self-refresh command This bit tells the DRAM controller to send the SELF command to both banks to cause the SDRAMs to enter into low-power self-refresh state where they will remain until the IS bit is cleared. When the IS bit is cleared, the DRAM controller will send the SELFX command to the SDRAMs to tell them to exit the self-refresh state. The refresh counter is suspended while the SDRAMs are in self-refresh. This bit is only relevent if the CPU is to be placed in low power mode. The BCM550 doesn't do this.0
10,9RTIM - Refresh TIMing These bits will determine the timing operation of Auto-Refresh in the SADRAMC. Specifically, it will determine the number of clocks inserted between the REF command and the next possible ACTV command. This same timing is used for both banks of the SADRAMC. This corresponds to tRC in the SDRAM specifications. It is given as 90nsec. 1/45mhz = 22nsec a cycle. Options are 3 and 6cycles, 3 gives 66 nsec, which is too short. 6 gives gives 133 nsec which is heaps.01
8->0Refresh Count - RC This field controls the frequency of refresh performed by the SADRAMC. One is added to the value stored in these register locations and multiplied by 16 bus clocks to determine the refresh period. The Refresh count is obtained from the SDRAM refresh cycle timing which states:
4096 refresh cycles in 64msecs.
64/4096 = .015625 msec a refresh
1/45mhz = .0000222 msec
0.015625/0.0000222 = 703.125 bus clocks.
To convert this to a RC field value, RC = (703.125/16)-1=42.945.
You round down as refresh have to be occure faster than minimum. A value of 42 is used.
The actual refresh time will be (42 +1)*16/45mhz = 15.28 usec 		00101011
 
	\ dram control register
	$100 #mba + CONSTANT _wreg_DCR
		$8000 CONSTANT _#dcr_syncronous_mode
		$0200 CONSTANT _#dcr_refresh_timing
		$002A CONSTANT _#dcr_refresh_count

Address and Control Register ( DACRx )

DARRx contain base address compare value and the control bits for both banks 0 and 1 of the DRAM controller. Address and timing are also controlled by bits in the DACRx registers.

\
DACRx
bitnameCommentBCM550
31->18BA - Base Address Register These register bits are used in conjunction with the BAM bits in the DCMR to determine the address range in which the associated bank of DRAM will be located. Each bit is compared with the corresponding address of the bus cycle in progress. If each bit matches, or if bits that do not match are masked in the BAM, the address hits in the associated banks DRAM block. DACR0 0001 0000 0000 00
DACR1 0001 0001 0000 00
17,16
Reserved00
15RE - Refresh Enable This bit determines if the SADRAMC will generate a refresh cycle to the associated DRAM bank. This bit is reset to zero to ensure that the refresh function is disabled at reset. In the end this bit will be set 1
14
Reserved00
13,12CASL - Column Address Strobe Latency These bits determine how long the data is delayed after the CAS signal (or the read command) is asserted during a SDRAM access. This data delay corresponds to the tRCD ( 30nsec = 2 cycles) specification in most SDRAMs. This also implies other timings with respect to the SDRAM. These include active command to precharge command (tRAS ?? ), precharge command to active command (tRP 30nsec=2 cycles ), last data input to precharge command (tRWL ??), and last data out to early precharge (tEP ?? ).
CASL[1:0]tRCDtRAStRPtRWLtEP
0012111
0124211
1036321
1136321
Note the last column of the above table changed from early to late revisions of the user's manual. 		01
11
Reserved00
10,9,8CBM - Command and Bank Mux Because different SDRAM configurations will cause the bank and column bits to correspond to different addresses these resources have been made programmable. These bits will determine the addresses these onto which these functions will be multiplexed. Table below shows the encoding of these bits. This encoding along with the address multiplexing scheme handles common organizations of 16-Mbit SDRAMs, as well as some organizations of 4-Mbit, and allowing room for future 64-Mbit implementations. Note that the bank select bits include a base bit and all address bits above. This is to allow for future implementations of SDRAM that have more than one bank select bit. The selected value has address line 22 and up used for bank select.
CBM[2:0]COMMAND BITBANK SELECT BITS
0001718 & UP
0011819 & UP
0101920 & UP
0112021 & UP
1002122 & UP
1012223 & UP
1102324 & UP
1112425 & UP
100
6IMRS - Mode Register Set Command This bit will generate the Mode Register Set (MRS) command to the associated SDRAMs. To use this feature, the base address and mask registers must be set. The associated CBM bits should also be initialized. After the IMRS bit is set, the next access to the address space of the SDRAM will cause the MRS command to that SDRAM to be generated. The address of the access should be selected in order to place the correct mode information on the address pins of the SDRAM. This bit is set to initiate a MRS command. The DRAM controller will clear the bit when the command is finished. Table 11-28 summarizes the function of the IMRS Bit. Any accesses via the IMRS bit should be restricted to be no wider than the port size programmed in the PS bits. -
5,4PS - Port Size These two bits will determine the port size of the associated bank of SDRAM which will allow for dynamic sizing of the associated accesses.
PS[1:0]PORT SIZE
0032-Bit Port
018-Bit Port
1016-Bit Port
1116-Bit Port
 00
3IP - Initiate Precharge all command This bit will cause a Precharge All (PALL) command to be generated to the associated SDRAM bank. This is useful in the power up sequence of SDRAMs. In order to use this feature, the base address and mask registers must be set. The associated CBM bits should also be initialized. After the IP bit is set, the next access to the address space of the SDRAM will cause the PALL command to that SDRAM bank to be generated. It is automatically cleared by the DRAM controller after the PALL command is finished. Any accesses via the IP bit should be restricted to be no wider than the port size programmed in the PS bits, otherwise two address cycles will be generated and only one is required. -
2PM - Page Mode This bit determines how the associated SDRAM bank supports page mode operation.
PMFUNCTION
0Page Mode on Bursts Only
1Continuous Page Mode
1
1,0
Reserved00
 
	\ address and control register bank 0
	$108 #mba + CONSTANT _lreg_DACR0
		$00008000 CONSTANT _#dacrx_RE    \ Refresh enable
		$00001000 CONSTANT _#dacrx_CASL  \ Column address strobe latency 01
		$00000400 CONSTANT _#dacrx_CBM   \ Command and bank mux address line 22 and up
		$00000040 CONSTANT _#dacrx_IMRS  \ Initiate mode register set
		$00000008 CONSTANT _#dacrx_IP    \ Initiate precharge all
		$00000004 CONSTANT _#dacrx_PM
		$00000000 CONSTANT _#dacrx_PS    \ Port size 32 bit
	\ mask register bank 0
.S .( _#dacrx_PS  )

Mask Register ( DMRx )

DRAM Controller Mask Registers - DMR0 & DMR1 MBAR+$10C,114. These registers contain bits to mask off the compare function for addresses as well as to control response to certain Transfer Type/Transfer Modifier combinations.

DCR
BitNameCommentBCM550
31->18BAM - Base Address Mask This register bits are provided to allow the user to mask or dont care the associated bit in the Base Address (BA) register. If the bit is zero, the associated address is ignored to generate the DRAM hit. This lets you connect various size DRAMs to the SADRAMC. Each sdram bank is 16meg long 00 0000 0011 1111
17,9Reserved00
8 WP - Write Protect This bit determines if the associated bank of DRAM is write protected. If the bit is set, write accesses to the block of memory space occupied by the DRAM bank will be ignored by the DRAM Controller.0
7->1C/I, AM, SC, SD, UC, UD - Address Modifier Masks These bits allow the associated type of access to be allowed to access DRAM. Table below shows the definition of the bits. If the bit is one, the associated access type is ignored. If the bit is zero, the associated access type is allowed to hit in the DRAM space.
ADDRESS MODIFIER BITASSOCIATED ACCESS TYPE
C/ICPU Space / Interrupt Acknowledge
AMAlternate Master
SCSupervisor Code
SDSupervisor Data
UCUser Code
UDUser Data
 100000
0V - Valid This bit is set to show that the registers that control the associated bank of DRAM have been initialized, and that the DRAM Controller can begin to decode DRAM accesses. 1
 
	$10C #mba + CONSTANT _lreg_DMR0
		$00FC0000 CONSTANT _#dmrx_address_mask
		$00000040 CONSTANT _#dmrx_addr_modifiers
		$00000001 CONSTANT _#dmrx_valid

See bank 0 for full description. 

 
	\ address and control register bank1
	$110 #mba + CONSTANT _lreg_DACR1
	\ mask register bank 1
	$114 #mba + CONSTANT _lreg_DMR1

Timer 1

See section 12 of the user's manual

Even if cpu locks up the 10msec interrupt has to continue.

Timer 1 mode

BitNameCommentValue
15->8PS - Prescaler Value The prescaler is programmed to divide the clock input by values (system bus clock/(16 or 1) or clock on TIN pin) from 1 to 256. The binary value 00000000 divides the clock by 1; the value 11111111 divides the clock by 256. 00001111 ( 0F)
7,6CE -Capture Edge and Enable Interrupt 11 = Capture on any edge and enable interrupt on capture event
10 = Capture on falling edge only and enable interrupt on capture event
01 = Capture on rising edge only and enable interrupt on capture event
00 = Disable interrupt on capture event
00
5OM - Output Mode 1 = Toggle output
0 = Active-low pulse for one system bus clock cycle (22ns at 45MHz)
0
4ORI - Output Reference Interrupt Enable 1 = Enable interrupt upon reaching the reference value
0 = Disable interrupt for reference reached (does not affect interrupt on capture function) 		1
3FRR - Free Run/Restart 1 = Restart: Timer count is reset immediately after reaching the reference value
0 = Free run: Timer count continues to increment after reaching the reference value 		1
2,1CLK - Input Clock Source for the Timer 11 = TIN pin (falling edge)
10 = System bus clock divided by 16. Note that this clock source is not synchronized to the timer; thus successive time-outs may vary slightly in length
01 = System bus clock divided by 1
00 = Stop count
01
0RST - Reset Timer This bit performs a software timer reset similar to that of an external reset, although while this bit is zero, the other register values can still be written, if necessary. Effectively, a transition of this bit from one to zero is what resets the register values. The counter/timer/ prescaler will not be clocked unless the timer is enabled.
1 = Enable timer
0 = Reset timer (software reset
 1
 
	\ timer1 mode register
	$140 #mba + CONSTANT _wreg_TMR1
		$0F 8 LSHIFT CONSTANT _#tmr1_PS  \ divide by 16
		$0000 CONSTANT _#tmr1_CE	     \ don't use capture mode
		$0020 CONSTANT _#tmr1_OM         \ pulse output  
		$0010 CONSTANT _#tmr1_ORI        \ interrupt on output
		$0008 CONSTANT _#tmr1_FRR        \ free running
		$0002 CONSTANT _#tmr1_CLK        \ system clock
		$0001 CONSTANT _#tmr1_RST        \ enable timer
		.S .( _#tmr1_RST )

timer1 reference register

1/45000000 * 1 * n * m = .01
n*m = 450000 = 16 * 28125

 
	$144 #mba + CONSTANT _wreg_TRR1
		#28125 CONSTANT _#trr1_value

timer1 capture register

 
	$148 #mba + CONSTANT _wreg_TCR1

timer1 counter register

 
	$14C #mba + CONSTANT _wreg_TCN1

timer1 event register

Writing true to the appropiate bit resets the interrupt

 
	$151 #mba + CONSTANT _breg_TER1
		01 CONSTANT _#ter1_CAP
		02 CONSTANT _#ter1_REF

Timere 2

Watchdog timer, this timer is reset at the end of #task_level_clock_medium. TIN toggles every 10msec, count therefor increments every 20msec.

timer2 mode register

 
	.S .( before _wreg_TMR2)
	$180 #mba + CONSTANT _wreg_TMR2
		$00 $8 LSHIFT CONSTANT _#tmr2_PS  \ No prescale required
		$0000 CONSTANT _#tmr2_CE	        \ don't use capture mode
		$0000 CONSTANT _#tmr2_OM         \ pulse output  
		$0010 CONSTANT _#tmr2_ORI        \ interrupt on output
		$0008 CONSTANT _#tmr2_FRR        \ free running
		$0003 CONSTANT _#tmr2_CLK        \ system clock
		$0001 CONSTANT _#tmr2_RST        \ enable timer

timer2 reference register

Set inital watchdog value to 2sec 

 
	$184 #mba + CONSTANT _wreg_TRR2
		#2sec 2 / CONSTANT _#trr2_value

timer2 capture register

 
	$188 #mba + CONSTANT _wreg_TCR2

timer2 counter register

 
	$18C #mba + CONSTANT _wreg_TCN2

timer2 event register

Writing true to the appropiate bit resets he interrupt

 
	$191 #mba + CONSTANT _breg_TER2
		01 CONSTANT _#ter2_CAP
		02 CONSTANT _#ter2_REF

UART

See section 14 of the users manual

 
	\ register offsets, common code is used to control both uarts
	| 00 CONSTANT _#m68_mode
	| 04 CONSTANT _#m68_clock_select
	| 04 CONSTANT _#m68_status
	| 08 CONSTANT _#m68_control
    | 0C CONSTANT _#m68_data
	| 10 CONSTANT _#m68_aux_control
	| 14 CONSTANT _#m68_int_enable
	| 14 CONSTANT _#m68_int_state
	| 18 CONSTANT _#m68_prescaler_MSB
	| 1C CONSTANT _#m68_prescaler_LSB
	| 30 CONSTANT _#m68_int_vector
	| 34 CONSTANT _#m68_input_port
	| 38 CONSTANT _#m68_output_set
	| 3C CONSTANT _#m68_output_reset
.S .( _#m68_output_reset)

	\ uart1 mode register 1
	\ Note the mode registers have the same offset.
	\ A write command issued to _breg_UCR1 will reset the
	\ register pointer. An access to the mode registers 
	\ will increment the pointer.  
	$1C0 #mba + CONSTANT _#m68a_base
	_#m68a_base _#m68_mode +          CONSTANT _breg_UMR11
	_#m68a_base _#m68_mode +          CONSTANT _breg_UMR21
	\ uart1 status register, read
	_#m68a_base _#m68_status +        CONSTANT _breg_USR1      
	\ uart1 clock select register, write
	_#m68a_base _#m68_clock_select +  CONSTANT _breg_UCSR1      
	\ uart1 command register
	_#m68a_base _#m68_control +       CONSTANT _breg_UCR1
	\ uart1 receive buffer, read
	_#m68a_base _#m68_data +          CONSTANT _breg_URB1
	\ uart1 transmit buffer, write
	_#m68a_base _#m68_data +          CONSTANT _breg_UTB1
	\ uart1 input port change register, read
	_#m68a_base _#m68_aux_control +   CONSTANT _breg_UIPCR1
	\ uart1 auxilary control register, write
	_#m68a_base _#m68_aux_control +   CONSTANT _breg_UACR1
	\ uart1 interrupt status register, read
	_#m68a_base _#m68_int_state +     CONSTANT _breg_UISR1
	\ uart1 interrupt mask register
	_#m68a_base _#m68_int_enable +    CONSTANT _breg_UIMR1
	\ uart1 baud rate prescaler ( MSB) 
	_#m68a_base _#m68_prescaler_MSB + CONSTANT UBG11
	\ uart1 baud rate prescaler ( LSB)
	_#m68a_base _#m68_prescaler_LSB + CONSTANT UBG21
	\ uart1 interrupt vector register
	_#m68a_base _#m68_int_vector +    CONSTANT UIVR1
	\ uart1 input port register
	_#m68a_base _#m68_input_port +    CONSTANT UIP1
	\ uart1 output port bit set register
	_#m68a_base _#m68_output_set +    CONSTANT UOP11
	\ uart1 output port bit reset register
	_#m68a_base _#m68_output_reset +  CONSTANT UOP01 


	\ uart2 mode register 1
	\ Note the mode registers have the same offset.
	\ A write command issued to _breg_UCR1 will reset the
	\ register pointer. An access to the mode registers 
	\ will increment the pointer.  
	$200 #mba + CONSTANT _#m68b_base
	_#m68b_base _#m68_mode +          CONSTANT _breg_UMR12
	_#m68b_base _#m68_mode +          CONSTANT _breg_UMR22
	\ uart1 status register, read
	_#m68b_base _#m68_status +        CONSTANT _breg_USR2     
	\ uart1 clock select register, write
	_#m68b_base _#m68_clock_select +  CONSTANT _breg_UCSR2      
	\ uart1 command register
	_#m68b_base _#m68_control +       CONSTANT _breg_UCR2
	\ uart1 receive buffer, read
	_#m68b_base _#m68_data +          CONSTANT _breg_URB2
	\ uart1 transmit buffer, write
	_#m68b_base _#m68_data +          CONSTANT _breg_UTB2
	\ uart1 input port change register, read
	_#m68b_base _#m68_aux_control +   CONSTANT _breg_UIPCR2
	\ uart1 auxilary control register, write
	_#m68b_base _#m68_aux_control +   CONSTANT _breg_UACR2
	\ uart1 interrupt status register, read
	_#m68b_base _#m68_int_state +     CONSTANT _breg_UISR2
	\ uart1 interrupt mask register
	_#m68b_base _#m68_int_enable +    CONSTANT _breg_UIMR2
	\ uart1 baud rate prescaler ( MSB) 
	_#m68b_base _#m68_prescaler_MSB + CONSTANT UBG12
	\ uart1 baud rate prescaler ( LSB)
	_#m68b_base _#m68_prescaler_LSB + CONSTANT UBG22
	\ uart1 interrupt vector register
	_#m68b_base _#m68_int_vector +    CONSTANT UIVR2
	\ uart1 input port register
	_#m68b_base _#m68_input_port +    CONSTANT UIP2
	\ uart1 output port bit set register
	_#m68b_base _#m68_output_set +    CONSTANT UOP12
	\ uart1 output port bit reset register
	_#m68b_base _#m68_output_reset +  CONSTANT UOP02

Parallet port

See section 10 of the users manual. See also _wreg_PAR. 

 
	\ parallel port data direction register
	$244 #mba + CONSTANT _wreg_PADDR
	\ parallet port data register
	$248 #mba + CONSTANT _wreg_PADAT

MBUS

See section 15 of the users manual. 

 
	\ mbus address register
	$280 #mba + CONSTANT _breg_MADR
	\ mbus frequency register
	$284 #mba + CONSTANT _breg_MFDR
	\ mbus control register
	$288 #mba + CONSTANT _breg_MBCR
	\ mbus status register
	$28C #mba + CONSTANT _breg_MBSR
	\ mbus data register
	$290 #mba + CONSTANT _breg_MBDR

DMA controller

See section 13 of the users manual 

 
	\ dma0 source address register 1
	$300 #mba + CONSTANT _lreg_SAR0
	\ dma0 destination address register 1
	$304 #mba + CONSTANT _lreg_DAR0
	\ dma0 control register 
	$308 #mba + CONSTANT _wreg_DCR0
		8000 CONSTANT _#dcrx_INT    \ enable interrupt on termination
		4000 CONSTANT _#dcrx_EEXT   \ external request
		2000 CONSTANT _#dcrx_CS     \ cycle steal
		1000 CONSTANT _#dcrx_AA     \ auto align
		0100 CONSTANT _#dcrx_SAA    \ single address mode
		0080 CONSTANT _#dcrx_S_RW   \ one = read
		0040 CONSTANT _#dcrx_SINC   \ source increment
		0008 CONSTANT _#dcrx_DINC   \ destination inc
		0001 CONSTANT _#dcrx_START  \ start
	\ dma0 count register
	$30C #mba + CONSTANT _wreg_BCR0
	\ dma0 status register
	$310 #mba + CONSTANT _breg_DSR0
	\ dma0 interrupt vector register
	$314 #mba + CONSTANT _breg_DIVR0

	\ dma1 source address register 1
	$340 #mba + CONSTANT _lreg_SAR1
	\ dma1 destination address register 1
	$344 #mba + CONSTANT _lreg_DAR1
	\ dma1 control register 
	$348 #mba + CONSTANT _wreg_DCR1
		0006 CONSTANT _#dcr1_DSZE
		0030 CONSTANT _#dcr1_SSZE
	\ dma1 count register
	$34C #mba + CONSTANT _wreg_BCR1
	\ dma1 status register
	$350 #mba + CONSTANT _breg_DSR1
	\ dma1 interrupt vector register
	$354 #mba + CONSTANT _breg_DIVR1

	\ dma2 source address register 1
	$380 #mba + CONSTANT _lreg_SAR2
	\ dma2 destination address register 1
	$384 #mba + CONSTANT _lreg_DAR2
	\ dma2 control register 
	$388 #mba + CONSTANT _wreg_DCR2
	\ dma2 count register
	$38C #mba + CONSTANT _wreg_BCR2
	\ dma2 status register
	$390 #mba + CONSTANT _breg_DSR2
	\ dma2 interrupt vector register
	$394 #mba + CONSTANT _breg_DIVR2

	\ dma3 source address register 1
	$3C0 #mba + CONSTANT _lreg_SAR3
	\ dma3 destination address register 1
	$3C4 #mba + CONSTANT _lreg_DAR3
	\ dma3 control register 
	$3C8 #mba + CONSTANT _wreg_DCR3
	\ dma3 count register
	$3CC #mba + CONSTANT _wreg_BCR3
	\ dma3 status register
	$3D0 #mba + CONSTANT _breg_DSR3
	\ dma3 interrupt vector register
	$3D4 #mba + CONSTANT _breg_DIVR3

function_data

 
	\ latch value. This is used to ID the software 
	\ version.
	_#function_data_base #00 + CONSTANT _breg_ID
	\ Interrupt reset must be done with a write, using a read can
	\ cause problems because a single read can result in multiple read
	\ cycles.
	\ Reset digital interrupt 1 
	_#function_data_base #02 + CONSTANT _breg_int_reset_digital0 
	\ Reset digital interrupt 2
	_#function_data_base #03 + CONSTANT _breg_int_reset_digital1 
	\ Reset interrupt for RTI Ac_low
	_#function_data_base #04 + CONSTANT _breg_int_reset_aclow
	\ Reset interrupt for RTI sys_fail 
	_#function_data_base #05 + CONSTANT _breg_int_reset_sys_fail
	\ Reset interrupt remote I/O 
	_#function_data_base #06 + CONSTANT _breg_int_reset_remote_i/o
	\ Reset bus error interupt
	_#function_data_base #07 + CONSTANT _breg_int_reset_bus_error
	\ end of service interrupt NICE controller ( DMA interrupt )
	_#function_data_base #10 + CONSTANT _breg_int_reset_ethernet
	\ system setup 0
 	_#function_data_base #27 + CONSTANT _breg_SS0 \ system_setup 0
		\ have to set to one.
		$0001 CONSTANT _#SS0_enable_logic  \ enables flip flops in fpga
		\ cause card to reset, this how I should reset card, don't use reset instruction
		$0002 CONSTANT _#SS0_self_reset
		\ if timer 2 times out and this bit is set card will do reset.
		$0004 CONSTANT _#SS0_enable_watchdog
		\ Set to remove RTI reset line.
		$0008 CONSTANT _#SS0_enable_rti
		\ enable bus error
		$0010 CONSTANT _#SS0_enable_bus_error
		$0040 CONSTANT _#SS0_port0>RS485
		$0080 CONSTANT _#SS0_port1>full_duplex
	_#function_data_base #28 + CONSTANT _breg_SS1 \ system setup 1
	\ Three leds
		$0001 CONSTANT _#SS1_dram_fault
		$0002 CONSTANT _#SS1_no_buffer_memory
		$0004 CONSTANT _#SS1_processor_fault
	\ digital interrupts
	\ bits 4 and 5 control digital interrupt 0
	\ 00 = no interrupt
	\ 01 = interrupt on falling edge.
	\ 10 = interrupt rising edge
	\ 11 = interrupt on both
	\ system status
		$0010 CONSTANT _#SS1_dig1_falling
		$0020 CONSTANT _#SS1_dig1_rising

		$0040 CONSTANT _#SS1_dig2_falling
		$0080 CONSTANT _#SS1_dig2_rising

	_#function_data_base #29 + CONSTANT _breg_SST0
		$0001 CONSTANT _#SST0_in_slotx
		
		\ 01 = base
		\ 11 = remote
		\ 10 = local

		$0008 CONSTANT _#SST0_digital_input1
		$0010 CONSTANT _#SST0_digtial_input2

	\ Use only the kernel
	$2 CONSTANT _#cold_restart
	\ Use startup script
    $6 CONSTANT _#warm_restart
	\ Use saved application
	$4 CONSTANT _#normal_restart
	
	$06 CONSTANT _#restart_method_bits

	\ Interrupt status register
	\ All interrupts are autovectored from base $90
	_#function_data_base #30 + CONSTANT _#IS2
		$0001 CONSTANT _#IS_digital_input1
		$0002 CONSTANT _#IS_digital_input2
		$0004 CONSTANT _#IS_ac_low
		$0008 CONSTANT _#IS_sysfail
		$0010 CONSTANT _#IS_remote_i/o
	\ fpga version
	_#function_data_base #31 + CONSTANT _breg_FPGA
		$0A1 CONSTANT _#FPGA_version
	\ Set RTI1000 interrupt ( slave mode only)
	_#function_data_base #32 + CONSTANT _#set_rti1000_interrupt
	\ Reset interrupt from master ( slave mode only)
	_#function_data_base #33 + CONSTANT _#reset_rti1000_interrupt
	 
 
	$60 CONSTANT _#m68a_vector
	$61 CONSTANT _#m68b_vector 
	$62 CONSTANT _#dma0_vector
	$63 CONSTANT _#dma1_vector
	$64 CONSTANT _#dma2_vector
	$65 CONSTANT _#dma3_vector

Describe the cache, needed for cache flushed. 

 
	2000 CONSTANT _#cache_size
	0010 CONSTANT _#cache_line_size
	0004 CONSTANT _#cache_sets
	.S .( end MCF5307_constants.html)
	 
 	 
	\ The kernel checksum can't go at the start because that is where the restart 
	\ vector is stored. So it is placed at the end,
	_prom_kernel_end 4 -                     EQU _prom_kernel_checksum
	_prom_kernel_end 8 -                     EQU _prom_kernel_count
 
	_prom_kernel_end                         EQU _prom_dictionary_image_start
	_prom_dictionary_image_start
	_#dictionary_image_size +                EQU _prom_dictionary_image_end

	_prom_dictionary_image_start             EQU _prom_dictionary_checksum
	_prom_dictionary_image_start 4 +         EQU _prom_dictionary_count

	_prom_kernel_start CONSTANT _interrupt_vectors  ( Start of interrupt vectors )

	\ Section 3.2.2 of user's manual
	_interrupt_vectors 0FFFFF AND 0 ??=


	                       
	_prom_kernel_end                  EQU _#dictionary_start
	800000 _#dictionary_start +       EQU _#dictionary_end  ( End of user dictionary)
	_#dictionary_end                  EQU RMEM4  ( Start of RAM area )
	_#sdram0_base _#sdram0_size + 1 - EQU RMEM5  ( End of ram area)

	100000   EQU _#dictionary_flash_base
	60000    EQU _#dictionary_flash_size


	\ Buffers must be in non cached area as you must be able to DMA
	_#sdram1_base $200000 + CONSTANT _#heap_start _#sdram1_size
	_#sdram1_base + CONSTANT _#heap_end
./version081/constants.html0100777000000000000000000000311507300314346014541 0ustar rootroot COLDFORTH KERNEL license

We are very dependent on TCP/IP coming up. If the local config file fails to load, which will happen if the local flash file is not there, we fall back to the following default. 


#BCM550h #BCM550j + [IF]
	10.0.0.1 CONSTANT #default_ip
[THEN]

	#100              CONSTANT #1sec
	#1sec 2*          CONSTANT #2sec
	#1sec #10 *       CONSTANT #10sec
	#1sec #60 * #60 * CONSTANT #1hour

#BCM550h #BCM550j + #BVP5502 + #BVP5501 + #BVP5552 + #BVP5551 + [IF]
	$240C CONSTANT #ilan_packet_max
[THEN]

	$13 CONSTANT #xoff
	$11 CONSTANT #xon
	$08 CONSTANT #back_space
	$07 CONSTANT #bell
	$03 CONSTANT #^c

	$09 CONSTANT #tab
	$0D CONSTANT #cr
	$0A CONSTANT #lf
	$1B CONSTANT #esc
	$1A CONSTANT #^z

\ Up to 9 levels plus room for 7 possible interrupts
\ eack interrupt can create a forth environment, should allow #256 bytes for each
#BCM550h #BCM550j + [IF]
	\ This is the maximum size that will fit in fast ram
	$1000           CONSTANT _#system_stack_length
[THEN]

#BVP5502 #BVP5501 + #BVP5552 + #BVP5551 + [IF]
	$2000           CONSTANT _#system_stack_length
[THEN]

	| $040          CONSTANT #line_size
	| $2000         CONSTANT #bigblock
	$10             CONSTANT #slot_num
./version081/bcm550_save.html0100777000000000000000000000572407300314346014546 0ustar rootroot COLDFORTH KERNEL license 
 
	\ high byte
	MARKER empty

	\ address has to be shifted on BCM522 as there is a
	\ high and low byte
	: _flash_start_erase ( base_address --)
		$AA OVER $5555 + C!
		$55 OVER $2AAA + C!
		$80 OVER $5555 + C!
		$AA OVER $5555 + C!
		$55 OVER $2AAA + C!
		$10 OVER $5555 + C!
		DROP
	; 

	: _flash_reset ( base --)
		$F0 SWAP C!
	;

	\ flag is true if still toggleing.
	: _flash_toggle? ( base_address --flag)
		DUP C@ $40 AND SWAP C@ $40 AND <> 
	;


	: _flash_erase ( base_address -- $ )
		DUP _flash_start_erase
		BEGIN
			DUP _flash_toggle?
			xtest 10 xwait
		WHILE
			DUP C@ $20 AND IF \ may of exceeded time
				DUP _flash_toggle? IF \ we did
					_flash_reset
					$" Failed to erase"
					EXIT
				THEN
			THEN
		REPEAT
		\ success if here
		DROP FALSE
	;

	: _flash_program_byte { ( value addr base -- $ ) }{
		variable _%base }
		_%base !
		\ We test one program byte back
		_%base @
		BEGIN
			DUP _flash_toggle?
		WHILE
			DUP C@ $20 AND IF \ may of exceeded time
				DUP _flash_toggle? IF \ we did
					_flash_reset
					2DROP
					$" Failed to program"
					EXIT
				THEN
			THEN
		REPEAT
		DROP
		$AA _%base @ $5555  + C!
		$55 _%base @ $2AAA  + C!
		$A0 _%base @ $5555  + C!
		_%base @ + C!
		FALSE
	;

	: _flash_block_write  { variable _%source 
		                    variable _%destination 
							variable _%base 
							variable _%number -- ( $ ) }
		_%number @ zero DO
			_%source @ I + C@
			_%destination @ I +
			_%base @ _flash_program_byte
			?DUP IF ( failed)
				UNLOOP
				EXIT
			THEN
			^C
		LOOP
		FALSE
	;

	$2000   CONSTANT _#8k
HOST 	_#copy_boot_flash_base forth CONSTANT _#flash_base
HOST	_#copy_boot_flash_size forth CONSTANT _#flash_size


	: image>flash { -- }{
	variable %handle
	}
	_#flash_base _flash_erase $ABORT
	_#8k get_buffer
	$" ./kernel.bin" R/W $open \ handle
	%handle !
	_#flash_size 0 DO
		buffer _#8k %handle @ ['] :read CATCH
		?DUP IF
			kill_buffer
			%handle @ close
			$ABORT
		THEN
		_#8k <> ABORT" File size wrong"
		buffer I  _#flash_base _#8k  _flash_block_write ?DUP IF ( write failed)
			kill_buffer
			%handle @ close
			ABORT" Failed to write data to prom"
		THEN
	_#8k +LOOP
	%handle @ close
	kill_buffer
;

: ?same_image ( -- )
	_#flash_size 0 DO 
		I %NEW_IMAGE + @ _#flash_base I + @ <> ABORT" Image failed to flash"
	4 +LOOP
;

	: new>flash ( --)
		.S ." new>flash"
		_#flash_base _flash_erase $ABORT
		.S ." erased"  
		%NEW_IMAGE 0 _#flash_base _#flash_size  _flash_block_write 
		.S ." write done"
		ABORT" Failed to write data to prom"
	;
./version081/kernel.html0100777000000000000000000004163507300314346014016 0ustar rootroot COLDFORTH KERNEL license
The cross compiler

include ./xcom.html  \ link

Change these flags to get what you want all cards are support under one source tree. Its too hard maintaining seperate version. 


	
	HEX  
	\ H 5307 mask
	FALSE     EQU #BCM550h
	\ J 5307 mask
	TRUE    EQU #BCM550j
	FALSE    EQU #BVP5502
	FALSE    EQU #BVP5501
	
	FALSE    EQU #BVP5552
	FALSE    EQU #BVP5551


	TRUE     EQU #USE_MAC
	
	\ add floating point package
	\ The H mask doesn't support the fractional mult.
	#BCM550h not [IF]
		TRUE     EQU #FLOAT
	[ELSE]
		FALSE EQU #FLOAT
	[THEN]
	
\ based on card type define type of processor
#BCM550h #BCM550j + #BVP5502 + #BVP5501 + [IF]
	TRUE  EQU #5307
	FALSE EQU #5407
	assembler
	#5300 !CPU
	HOST
[THEN]

#BVP5552 #BVP5551 + [IF]
	FALSE EQU #5307
	TRUE EQU #5407
	assembler
	#5400 !CPU
	HOST
[THEN]

\ assumes SDRAM starts at $10000000 
#BCM550h #BCM550j + #BVP5502 + #BVP5501 + #BVP5552 + #BVP5551 + [IF]
	include ./setup_xcom.html \ link
[THEN]

We can now add code to image 



include ./constants.html

#BCM550h [IF]
	include ./bcm550h_constants.html \ link
[THEN]

#BCM550j [IF]
	include ./bcm550j_constants.html \ link
[THEN]

#BVP5502 [IF]
	include ./bvp5502_constants.html \ link
[THEN]

#BVP5501 [IF]
	include ./bvp5501_constants.html \ link
[THEN]

#BVP5551 [IF]
	include ./bvp5551_constants.html \ link
[THEN]

#BVP5552 [IF]
	include ./bvp5552_constants.html \ link
[THEN]

	
	\ target dictionary pointer, see dictionary_here
	_#dictionary_start 'dictionary !
	\ base address of the dictioanry image area
	\ used in XCOM
	_#dictionary_start _dictionary0 !

Run time action for various words. 


	include ./_do_code.html \ link
	include ./ansi_code_words.html \ link
	include ./code_words.html \ link

load rest of cross compiler

The cross compiler needs to know where some of the words are in the kernel. There are two ways of dealing with this, allow forward referencing in the cross compiler, or define the words and load the rest of the cross compiler. This version uses the latter approach. Can't argue in favour of either solution. 


	include ./xcomp2.4th \ link
	include ./ansi_code_strict_html.html \ link
	include ./start_application_dict.html \ link
	include ./colon_words_used_by_ansi.html \ link
	include ./ansi_colon_words.html \ link
	include ./colon_words.html \ link
	include ./word_head.html \ link
	include ./initial_abort.html \ link
	include ./link_lists.html \ link
	include ./user_variables.html \ link

#BCM550h #BCM550j + [IF]
	fast_here CONSTANT _%system_stack HOST _#system_stack_length fast_allot
	fast_here EQU _%system_stack_end 
	ram_variable _%fault_lp
	ram_variable _%fault_u
	ram_variable _%fault_stack _#system_stack_length ram_allot
[THEN]
\ #### temp #BCM552 should be static
\ Static may not be best.
 #BVP5502 #BVP5501 + #BVP5552 +  #BVP5551 +  [IF]
	ram_here CONSTANT _%system_stack HOST _#system_stack_length ram_allot
	ram_here EQU _%system_stack_end 
	ram_variable _%fault_lp
	ram_variable _%fault_u
	ram_variable _%fault_stack _#system_stack_length ram_allot
[THEN]

Fast memory defined before this is not cleared on startup. 


		
	fast_here CONSTANT _%fast_clear_start

dynamic ram memory defined before this is not cleared on startup. 

 
	
	ram_here  CONSTANT _%ram_clear_start

#BVP5502 #BVP5501 + #BVP5552 + #BVP5551 + [IF]

Static memory defined before this is not cleared on startup. 

 
	static_here CONSTANT _%static_clear_start
[THEN]

The kernel checksum is contained in prom, the application in flash. The application will only run if it was compiled on the same kernel. To this end the kernel checksum is saved with the application. Before the application is loaded the current kernel checksum is compare with the saved checksum and tha application loaded if the two checksums are the same.

An offset is used to find the checksum in the flashed application image. 

 
    dictionary_here _#dictionary_start  - CONSTANT _#kernel_checksum_offset   
    dictionary_variable _%kernel_checksum ( value copied when promming)


	include ./user_using_words.html \ link
	include ./memory_allocation.html \ link
	include ./vocabulary.html \ link
	include ./checksum.html \ link
	include ./find.html \ link
	include ./xwords.html \ link
	include ./task_loops.html \ link

#BCM550j #BCM550h + [IF]
	include ./panic0.html \ link
[THEN]

#BVP5502 #BVP5501 + #BVP5552 + #BVP5551 + [IF]
	include ./panic1.html \ link
[THEN]

	include ./heap_control.html \ link
	include ./words_using_heap.html \ link
	include ./wordlists.html \ link

sort out the root voacubulary. The minimum search order is SET-ORDER and FORTH-WORDLIST. To get into forth the code would be FORTH-WORDLIST 1 SET-ORDER We will add the word FORTH. 

 
	target_also &root 
	target_definitions

	: FORTH  FORTH ;
	: FORTH-WORDLIST FORTH-WORDLIST ;
	: SET-ORDER SET-ORDER ;	

	target_previous_definitions
	target_previous

    
  
 
  
	include ./cache_managment.html \ link
	include ./basic_io.html \ link
	include ./number_output.html \ link
	include ./abort.html \ link
	include ./ass.html \ link
	include ./word.html \ link
	include ./more_ansi_colon_words.html \ link
	include ./compile.html \ link
	include ./string_literals.html \ link
	include ./number.html \ link
	include ./random.html \ link

	#FLOAT [IF]
		include ./float.html \ link
	[THEN]
	include ./q_numbers.html \ link
	include ./version.html \ link        
	include ./more_forth.html \ link    
	include ./struct.html \ link
	include ./objects.html \ link
	include ./terminal_class.html \ link
	include ./linked_object.html \ link
	include ./string_class.html \ link

	include ./parented_object.html \ link
	include ./inode.html \ link
	include ./io_common.html \ link
	include ./root.html \ link
	include ./file_class.html \ link
	include ./input_output.html \ link
	include ./ws60.html \ link
	include ./prompt.html \ link
	include ./if_then_else.html \ link
	include ./htmltags.4th \ difficult to display; defines HTML tags. 
	include ./quit_interpret_etc.html \ link
	include ./queue.html \ link
	include ./flash.html \ link
	include ./local_variables.html \ link
	include ./system_rte.html \ link
	include ./interrupt_colon.html \ link
	.S .( after ./interrupt_colon)
	include ./tyx.html \ link
	.S .( after ./tyx)
	include ./config.html \ link
	.S .( after ./config.html)
	include ./real_time_clock.html \ link
	.S .( after ./real_time_clock)
	include ./editor.html \ link
	.S .( after ./editor)
	include ./date1900.html \ link
	.S .( ./date)
	include ./form.html \ link
\	include ./message.html  
	include ./_cvs_decode.html \ link
	.S .( ./_cvs_decode)
\ works but is of little use, intertask is done with tube
\	include ./pipe.html \ link

#BCM550h #BCM550j + #BVP5502 +  #BVP5552 + #BVP5551 +  [IF]
	include ./dual_port_memory.html \ link
[THEN]

#BVP5502 #BVP5501 +  [IF]
	include ./bank_memory.html \ link
[THEN]

\ same structure as rtidual port
#BVP5552 [IF]
	include ./bvp5552bank_memory.html
[THEN]

	include ./tube.html \ link
.S .( after ./tube.html)
#BCM550h #BCM550j +  #BVP5502 +  #BVP5552 + #BVP5551 + [IF] 
	include ./port_tube.html \ link     
[THEN]

	include ./task_stuff.html \ link
	include ./marker.html \ link  
	include ./print_system_data.html \ link  
	include ./words.html \ link
	include ./operator_task_table.html \ link    
	include ./show.html \ link
	include ./fault_data.html \ link

	include ./watchdog.html \ link    
	include ./traps.html \ link	

#BCM550h #BCM550j + [IF]    
    include ./cards.html \ link
[THEN]

	include ./printing.html \ link
	
#BCM550h #BCM550j + [IF]
    include ./rlogon.html \ link
[THEN]

		: get_filecode ( --code)
			this :@name checksum 
		;

	include ./ilan_temp.html \ link    
    
#BCM550h #BCM550j + [IF]
 	include ./rti1000_interrupt.html \ link
[THEN]

#BCM550h #BCM550j + [IF]
	include ./digital_interrupt.html \ link
[THEN]

#BCM550h #BCM550j + #BVP5502 + #BVP5552 + #BVP5551 + [IF]
	include ./rti.html \ link
[THEN]

\ #### temp
\ getting file services through the bank memory between CPUI and CPUII
\ #BVP5501 [IF]
\	include ./bank.html \ link
\	include ./bank_tube.html \ link
\ [THEN]


\ #BCM550 [IF]
\    include ./file_server.html \ link
\ [THEN]

#BVP5552  [IF]
    include ./bank_bvp5552_code.html \ link
    include ./bank_bvp5552_logon.html \ link
[THEN]
#BVP5502  [IF]
    include ./bank_bvp5502_code.html \ link
    include ./bank_logon.html \ link
[THEN]

	include ./bye_restart_etc.html \ link

	include ./dma.html \ link

	.S .( start tcpset)
	include ./tcp/temp.html \ link
	include ./tcp/pep_h.html \ link
	include ./tcp/icmp_h.html \ link
	include ./tcp/routing_h.html \ link
	include ./tcp/tcp_h.html \ link
	include ./tcp/print_pep.html \ link

	\ must be defined now as used in icmp_demux
	include ./tcp/interface_common.html \ link
	include ./tcp/ip_setup.html \ link
	include ./tcp/io_protocol_common.html \ link

	\ these have to be defined before the interface classes derived because
	\ the :!ip words and :!netmask words have to
	\ add and remove routes.
	include ./tcp/routing.html \ link
	include ./tcp/interface_local.html \ link
	\ defined before proto.html as used there
	include ./tcp/demux.html \ link
	include ./tcp/demux_socket.html \ link
	\ defined before interface_loopback as interface_loopback
	\ has to call the :proto_checksum method
	include ./tcp/proto.html \ link
	include ./tcp/interface_loopback.html \ link

#BCM550h #BCM550j + [IF]
	include ./tcp/ethernet_h.html
	include ./tcp/interface_nice.html
[THEN]

	include ./tcp/udp_demux.html \ link
	include ./tcp/tcp_demux.html \ link
	include ./tcp/icmp_demux.html \ link
	include ./tcp/udp.html \ link
	include ./tcp/icmp_echo.html \ link
	include ./tcp/timestamp.html \ link
	include ./tcp/tcp_client.html \ link
	include ./tcp/tcp_server.html \ link
	include ./ansi.html         \ link
	include ./tcp/rpc.html      \ link
	include ./tcp/nfs.html      \ link

	include ./tcp/telnet_server.html \ link
	include ./tcp/html.html \ link

	include ./kernel_tasks.html \ link
	
	include ./init.html \ link

#BCM550h [IF]
	include ./bcm550h_boot_to_ram.html \ link
[THEN]

#BCM550j [IF]
	include ./bcm550j_boot_to_ram.html \ link
[THEN]

#BVP5502 [IF]
	include ./bvp5502_boot_to_ram.html \ link
[THEN]

#BVP5501 [IF]
	include ./bvp5501_boot_to_ram.html \ link
[THEN]

#BVP5552 [IF]
	include ./bvp5552_boot_to_ram.html \ link
[THEN]

#BVP5551 [IF]
	include ./bvp5551_boot_to_ram.html \ link
[THEN]


	include ./locate.html \ link
	include ./glossary.html \ link

\	include ./print_source.html

	include ./op_function_vectors.html \ link
	include ./environment.html \ link

#BCM550h #BCM550j + [IF] 
	include ./bcm550_vectors.html \ link
[THEN]

#BVP5502 [IF]
	include ./bvp5502_vectors.html \ link
[THEN]

#BVP5501 [IF]
	include ./bvp5501_vectors.html \ link
[THEN]

#BVP5552 [IF]
	include ./bvp5552_vectors.html \ link
[THEN]

#BVP5551 [IF]
	include ./bvp5551_vectors.html \ link
[THEN]

	DECIMAL
	include ./end.4th \ link
	forth
	include ./bcm550_save.html \ link
	
.S .( ABOUT TO FLASH)
	new>flash
.S .( ABOUT TO TEST FOR SAME)
	?same_image
.S  .( finished)
./version081/bcm550_vectors.html0100777000000000000000000001404307300314346015267 0ustar rootroot COLDFORTH KERNEL license ( BCM520 Code that sets the exception code addresses) HEX
Interrupt source
source AVECLevelIPVectorcomment
SWT 0 7(1) 0040
Timer 1 1 6(2) 111E 10 msec
Timer 2 1 5(3) 111D Watchdog
MBUS 1 4(5) 111C Not used
UART1 0 6(4) 1160
UART2 0 6 1061
DMA0 0 2 1162 Ethernet
DMA1 0 2 1063 User
DMA2 0 2 0164 Uart0
DMA3 0 2 0065 Uart1
reserved1 3 101B
reserved1 3 011B
EINT7 1 7(1) - 1F Bus error
EINT6- - - -
EINT50 5 - 80->8FRTI1000 bus
EINT4- - - -
EINT3-a0 3(6) - 90 Digital1
EINT3-b" " - 91 Digital2
EINT3-c" " - 92 RTI-Aclow
EINT3-d" " - 93 RTI-Sysfail
EINT3-e" " - 94 Remote_I/O
EINT20 - - -
EINT11 1 - 19 ethernet

Remember ot update _exception_names in fault_data.html if you alter the exception table. 

 
	CODE /VECTORS
	TRAP02          02 EXCEPTION  ( access error)
	TRAP03          03 EXCEPTION  ( Address error)
	TRAP04          04 EXCEPTION  ( illegal intstruction)
	(               05 EXCEPTION  ( reserved)
	(               06 EXCEPTION  ( reserved)
	(               07 EXCEPTION  ( reserved)
	TRAP08          08 EXCEPTION  ( Privilage violation)
	TRAP09          09 EXCEPTION  ( Trace)
	TRAP0A          0A EXCEPTION  ( line 1010 emulation)
	TRAP0B          0B EXCEPTION  ( line 1111 emulation)
	TRAP0C          0C EXCEPTION  ( Hardware breakpoint)
	(               0D EXCEPTION  ( reserved)
	TRAP0E          0E EXCEPTION  ( stack frame format error)
	TRAP0F          0F EXCEPTION  ( Unitialised vector)
	( Code that sets the exception code addresses) HEX
	(    10 -> 17      EXCEPTION  ( Unassigned and reserved)
	(               18 EXCEPTION  ( Spurious interrupt)
	ethernet        19 EXCEPTION  ( level 1 interrupt autovector)
\	reserved        1A EXCEPTION  ( level 2 interrupt autovector)
	(               1B EXCEPTION  ( level 3 interrupt autovector)
\	mbus          	1C EXCEPTION  ( level 4 interrupt autovector)
\ watchdog timeout
\	watch_int       1D EXCEPTION  ( level 5 interrupt autovector)
	real_clock      1E EXCEPTION  ( coldfire level 6 interrupt autovector)
\ buss error
	TRAP1F          1F EXCEPTION  ( level 7 interrupt autovector)
	(               20 EXCEPTION )
	(               21 EXCEPTION )
	TRAP22          22 EXCEPTION ( switch tasks)
	TRAP23		    23 EXCEPTION ( execute word in super mode)
	TRAP25          25 EXCEPTION ( reset)
	TRAP26          26 EXCEPTION ( Run tcp level)
	TRAP27          27 EXCEPTION ( switch task levels)
	TRAP28          28 EXCEPTION ( 08 trap, all interrupts)
	TRAP29          29 EXCEPTION ( 09 trap, level 1 interrupts)
	TRAP2A          2A EXCEPTION ( 0A trap, level 2 interrupts)
	TRAP2B          2B EXCEPTION ( 0B trap, level 3 interrupts)
	TRAP2C          2C EXCEPTION ( 0C trap, level 4 interrupts)
	TRAP2D          2D EXCEPTION ( 0D trap, level 5 interrupts)
	TRAP2E          2E EXCEPTION ( 0E trap, level 6 interrupts)
	TRAP2F          2F EXCEPTION ( 0F trap, level 7 interrupts)
	( 30 -> 3F         EXCEPTION ( reserved)

	( 60)
	_8monitor_a     _#m68a_vector EXCEPTION
	( 61)
	_8monitor_b     _#m68b_vector EXCEPTION

	_dma0_exception _#dma0_vector EXCEPTION
	_dma1_exception _#dma1_vector EXCEPTION
	_dma2_exception _#dma2_vector EXCEPTION
	_dma3_exception _#dma3_vector EXCEPTION


	0rti_service    $8F EXCEPTION
	1rti_service    $8E EXCEPTION
	2rti_service    $8D EXCEPTION
	3rti_service    $8C EXCEPTION
	4rti_service    $8B EXCEPTION
	5rti_service    $8A EXCEPTION
	6rti_service    $89 EXCEPTION
	7rti_service    $88 EXCEPTION
	8rti_service    $87 EXCEPTION
	9rti_service    $86 EXCEPTION
	Arti_service    $85 EXCEPTION
	Brti_service    $84 EXCEPTION
	Crti_service    $83 EXCEPTION
	Drti_service    $82 EXCEPTION
	Erti_service    $81 EXCEPTION
	Frti_service    $80 EXCEPTION

	digital_int0    $97 EXCEPTION
	digital_int1    $96 EXCEPTION
	aclow           $95 EXCEPTION
	sys_fail        $94 EXCEPTION
	remote_io       $93 EXCEPTION

	NEXT
	' /VECTORS (/VECTORS) t!
./version081/buffer_abstract.html0100777000000000000000000000200307300314346015654 0ustar rootroot COLDFORTH KERNEL

COLDFORTH Heap Management

TCP/IP places unknown memory demands on a system.

IP requires you to receive an unknown number of datagrams, of unknown size. The datagrams could be IP fragments. You can have an unknown number of datagrams being reconstructed from the fragments. The number of routes is unknown. The number of entries in your ARP table is unknown, and so it goes.

If you are going to support TCP/IP in a manner that is close to the RFC requirements, pre allocation of the memory needed for IP reception is difficult. You have to support ALLOCATE and FREE.

The article describes the COLDFORTH heap management system.

./version081/buffer_paper.html0100777000000000000000000002774507300314346015204 0ustar rootroot COLDFORTH KERNEL

COLDFORTH Heap Management

TCP/IP places unknown memory demands on a system.

IP requires you to receive an unknown number of datagrams, of unknown size. The datagrams could be IP fragments. You can have an unknown number of datagrams being reconstructed from the fragments. The number of routes is unknown. The number of entries in your ARP table is unknown, and so it goes.

If you are going to support TCP/IP in a manner that is close to the RFC requirements, pre allocation of the memory needed for IP reception is difficult. You have to support ALLOCATE and FREE.

This article describes the COLDFORTH heap management system.

Design Aims

  • Portability. All code is in FORTH.
  • Run without an MMU
  • Buffers are self describing; that is all you need to return a buffer is the buffers address.
  • Memory fragmentation is controlled.
  • You can work out what is going on; where and when a buffer is used is recorded.
  • As fast as possible, given the other design aims.

Dealing with fragmentation was and is the most difficult problem.

Fragmentation

Its difficult to put Humpty Dumpty back together.

A system that doesn't use a MMU for memory control has to create a small memory area from a larger area, leaving a remainder. When the small area is returned to the heap management system, there is a fair chance that the some of the remainder has been allocated to another task and the large area can no longer be reconstructed.

The COLDFORTH heap management system does not solve this problem, but the design makes it possible to quickly recombine buffers that are meant to be combined.

Two design decisions set the tone of the whole heap management package. Both reduce de-fragmentation costs.

Memory-blocks from which user buffers are created are binary multiples, that is they have a size $40 bytes, $80 bytes, $100 bytes etc.

The address of a memory block has bits below its size set to zero. That is, the address of a $80 byte memory block can have the base address $180, but cannot have the base address $140. The following diagram tries to demonstrate the reason for this restriction.

Because we insist that the bits below the block size are zero the first case will not happen.

The heap management system

The heap management system can be divided into two parts. The code you interact with when getting or returning a buffer. And the low level task that recombines the buffers.

The data structures

The following diagram shows a $40 byte memory block linked into the $40 byte Empty list.

The following is worth noting:

  • Every memory block starts with a system header.
  • The user buffer is shorter than the memory block
  • The address of the user buffer is after the system header
  • Memory blocks are build out of units that are binary multiple of the minimum memory block size.

If you use the word ALLOCATE you will be returned a memory block from one of the empty lists. For example a buffer created from a $40 byte memory block will be returned for any ALLOCATE request less an $1C bytes. The memory block will be $40 bytes, the address returned will be after the system header, and no matter what length requested, the usable data area will be $1C bytes.

Any ALLOCATE request greater than $1C bytes and less than $5D bytes will be returned a buffer created from a memory block that was linked into the $80 byte memory block list.

This may seem pretty dam inefficient, from a $40 byte memory block the user only gets $1C bytes of usable memory. If you want a $8000 byte buffer, it is created from a $10000 byte memory block. The heap management system has given you a usable buffer $7FDC bytes longer than you want.

Yep it's pretty inefficient, but it's a lot better than having your memory broken up into a lot of small chunks that you can't put back together.

Getting the memory block

When you ask for a memory area, the heap management system first goes to the memory block list that has memory blocks that will just satisfy your needs. If there is no buffer available in the list, the buffer splitting routine _get_more_buffers is called. This routine will go to the next list and attempt to split into two, a buffer from that list. If there is no buffer in that list it will go to the next list and ......._get_more_buffers is a recursive routine.

Life is tough for _get_more_buffers , the COLDFIRE heap management system has to be able to meet the needs of tasks running at many different priorities, in a manner that doesn't hold the system up.

A low level task can be using _get_more_buffers just to find that a high level task has pinched the buffers created. _get_more_buffers has to be happy and just do the job again, this it does.

Putting Humpty Dumpty back together

The buffer return words and the buffer_reclaim task co-operate. The buffer return words return the buffers to the list in an address sorted order. This may seem like an excessive runtime overhead. Two things have to be remembered. The buffer_reclaim is trying to keep the list short, and life would be very difficult for buffer_reclaim if the list were not sorted.

Because the lists are sorted, because the buffers are allocated in binary multiples, and because the bits below the memory block size have to be zero, buffer reclaim is reasonably simple.

Buffer reclaim deals with one buffer size list at a time, trying to combine and move the resultant buffer to the next list. If the base address of the buffer is an acceptable address for the next list up, it checks to see if the next buffer in the list is the next memory block ( _?joinable ). If both these conditions are met the reclaim word joins the buffer and puts it in the next list.

Seems simple. Life gets complicated because this must occurs with high priority tasks returning and claiming buffers. A buffer that was in the list when the test was done, may be in use by the time joining is to occur. The complications and how they are dealt with can be seen by looking at the code for _?join_buffer_code

Keep track of Humpty Dumpty

As soon as you introduce a heap management system, you have memory leaks. If you keep track of memory usage you can determine the guilty and dismiss the innocent

An abort buffer allocated to a task is linked in as shown in the following diagram.

The used buffer list heads are only used by words that display buffer usage, for example .buffers and .buffers_used. The abort list is used to return buffers to the central pool on a task abort. The word get_abort_buffer ( pointer n--addr) allows you to supply the address of a cell that is reset to zero on a task abort. The cell is typically used to store the address of the buffer as shown in the diagram. The application however is free to use it as it pleases.

application words

The COLDFIRE heap management system provides four ways of getting a memory block.

word description returning word
get_buffer ( n --) The address of the buffer will be returned by buffer. If a task abort occurs the buffer will be returned to the free buffer pool. kill_buffer ( addr --)
get_abort_buffer ( pointer n--addr) The system will assume the address of the buffer is stored at pointer, but it doesn't do the store for you. If a task abort occurs the value stored in pointer will be set to zero, and the buffer will be returned to the free buffer pool. If the get_abort_buffer operation fails, an abort occurs. kill_abort_buffer ( addr--)
get_free_buffer ( n--) Word returns the address of the buffer. The buffer will not be returned if the task aborts, it is your responsibility. Buffers used to transfer data to TCP/IP ( pep buffers) must be created in this way. kill_free_buffer ( addr--)
ALLOCATE ( n --addr ior) If a task abort occurs the buffer will be returned to the free buffer pool. If the ALLOCATE operation fails ior points to a string describing the error. FREE ( addr--)

The standard gives us one way to allocate memory from the heap, COLDFORTH gives you four. Some may ask. What is this nonsense?.

The standard is very quiet on what happens when a task aborts. Should the memory claimed by the task be returned, or should if be left to the programmer to use CATCH and THROW to return the memory in an orderly fashion. I believe the system should reclaim the memory. When programming you want to deal with the problem not side issues such as this.

If ALLOCATE returns memory to the heap management system on an abort, then you need a set of words that does not. When using memory blocks to move data between tasks it is important that aborting one task doesn't invalidate memory owned by another. get_free_buffer and kill_free_buffer are used for this purpose.

get_about_buffer and kill_abort_buffer are used to deal with data areas created from the heap. For example: 

 
VARIABLE %data_pointer
: setup_task ( --)
	#data_length get_abort_buffer %data_pointer !
;

:task somthing ( --)
	setup_task
	task_action
;task

If the task aborts the data area will be returned to the heap management system, and the cell containing the pointer reset back to zero.

get_buffer and kill_buffer are historic CVS words. They are a lot easier to use than ALLOCATE and FREE. The following code demonstrates their use. 

 
: do_some_stuff ( addr n --)
	DUP get_buffer
		buffer  SWAP MOVE
		$100 buffer do_stuff
			get_buffer
				\ now dealing with second buffer
				buffer do_more_stuffer
			kill_buffer
		\ now dealing with first buffer
		buffer print_stuff
	kill_buffer
;

Basically get_buffer and kill_buffer take the buffer address away from the stack. There is a word ( buffer ) that returns the address of the current buffer.

./version081/bugs.txt0100777000000000000000000000021707300314346013340 0ustar rootroot1) Interrupt level should be lowered to correct level in txy code. 2) Interupts level lowered in timer routine 3) Better dynamic memory test../version081/bvp5501_boot_to_ram.html0100777000000000000000000004313207300314346016216 0ustar rootroot COLDFORTH KERNEL license 
 
CREATE  _boot_to_sdram assembler

Preset registers so early exception displays look nice. 

 
	$C0DE00 # D0 MOV
	$C0DE01 # D1 MOV
	$C0DE02 # D2 MOV 
	$C0DE03 # D3 MOV
	$C0DE04 # D4 MOV
	$C0DE05 # D5 MOV
	$C0DE06 # D6 MOV
	$C0DE07 # D7 MOV
	$C0DE08 # A0 MOV
	$C0DE09 # A1 MOV
	$C0DE0A # A2 MOV
	$C0DE0B # A3 MOV
	$C0DE0C # A4 MOV
	$C0DE0D # A5 MOV
	$C0DE0E # A6 MOV
	$C0DE0F # A7 MOV

Set module base address register. 

 
	#mba _#mbar_valid_bit + # D0 MOV
	D0 MBAR MOV

As we want to write to duel port memory setting up the chip select registers is the next thing that needs to be done.

Chip Select zero. 

 
	_#boot_flash_base #16 RSHIFT # D0 MOV
	D0 _wreg_CSAR0 AB W. MOV

	_#cscr0_wait_states 
	_#cscrx_AA          + \ auto acknowledge
	_#cscr0_port_size   +  # D0 MOV
	D0 _wreg_CSCR0 AB W. MOV

	_#boot_flash_size 1 - FFFF0000 forth AND assembler  # D0 MOV 
	D0 _lreg_CSMR0 AB MOV

	_#boot_flash_size 1 - FFFF0000 forth AND assembler 
	_#csmrx_V + # D0 MOV 
	D0 _lreg_CSMR0 AB MOV

Chip Select one. 

 
	_#application_flash_base #16 RSHIFT # D0 MOV
	D0 _wreg_CSAR1 AB W. MOV

	_#cscr1_wait_states 
	_#cscrx_AA          + \ auto acknowledge
	_#cscr1_port_size   +  # D0 MOV
	D0 _wreg_CSCR1 AB W. MOV

	_#application_flash_size 1 - FFFF0000 forth AND assembler # D0 MOV 
	D0 _lreg_CSMR1 AB MOV

	_#application_flash_size 1 - FFFF0000 forth AND assembler 
	_#csmrx_V + # D0 MOV 
	D0 _lreg_CSMR1 AB MOV

	\ #### temp
	_#application_flash_base AB D0 MOV

Chip Select two to seven base. 

 
	_#csbar #24 RSHIFT # D0 MOV
	D0 _breg_CSBAR AB B. MOV

Chip select 2, RTI1000 duel port. This memory is relevent if the card is used as a slave. See CSCR0->7 for further disscussion. 

 
	_#cscr2_wait_states 
	_#cscrx_AA          + \ auto acknowledge
	_#cscr2_port_size   +  
	_#cscrx_BEM         +  # D0 MOV
	D0 _wreg_CSCR2 AB W. MOV

See CSMR0->7 for further disscussion.

Enable the 2 meg address space, this value is probable common for chip selects 2 to 7. The masks existance is not documented in the User manual. But it definitly existed on 5307 used to being the system up. 

 
	000F0000 # D0 MOV 
	D0 _lreg_CSMR2 AB MOV

	000F0000  
	_#csmrx_V + # D0 MOV 
	D0 _lreg_CSMR2 AB MOV

Chip select 3, Bank memory. 

 
	_#cscr3_wait_states 
	_#cscrx_AA          + \ auto acknowledge
	_#cscr3_port_size   +  
	_#cscrx_BEM         +  # D0 MOV
	D0 _wreg_CSCR3 AB W. MOV
	 
 
	_#csmrx_V # D0 MOV 
	D0 _wreg_CSMR3 AB W. MOV

Chip select 6 duel port memory 

 
	_#cscr6_wait_states 
	_#cscrx_AA          + \ auto acknowledge
	_#cscr6_port_size   +  
	_#cscrx_BEM         + # D0 MOV
	D0 _wreg_CSCR6 AB W. MOV

	_#csmrx_V  # D0 MOV 
	D0 _wreg_CSMR6 AB W. MOV

Chip select 7, function_data 

 
	_#cscr7_wait_states 
	_#cscrx_AA          + \ auto acknowledge
	_#cscr7_port_size   +  # D0 MOV
	D0 _wreg_CSCR7 AB W. MOV

	_#csmrx_V  # D0 MOV 
	D0 _wreg_CSMR7 AB W. MOV


	\ Just played with chip select, put in a NOP just in case problems occure.
	NOP

	\ finished chip select init 
	_#finished_chip_select # D0 MOV
	D0 %port_init_where  AB MOV

We want to use the stop instruction, so we had better enable it. 

 
	_#pllcr_ENBSTOP  \ enable stop
	_#pllcr_PLLIPL   + # D0 MOV \ phase lock loop interrupt priority.
	D0 _breg_PLLCR AB B. MOV

Getting the sdram started

User's manual section 11.6.2.1.2 discusses the problem.

After Power is applied and all clocks are running and stable a 100usec delay is required. Then the SDRAM accepts commands. During this time the MCF5307 SDRAM controller registers can be setup.

Setting up the timer for DRAM startup timing

We have decided to use only one time delay 100 usec. At 45Mhz ( timer input clock) 100 usec is. 100 / .022222 = 4500 cycles. This is well within the range of the counter with no prescaling.

Timer Mode Register
fieldvaluecomment
PSt->PS000000000Divide by 1
CE1->CE000Disable interrupt on capture event
OM0Don't care
ORI0No interrupts
TRR0Free run
CLK1->CLK001System clock/1
RST1Enable tinmer

Set the timer mode register to 03. 

 
	\ disable timer
	0 # D0 MOV
	D0 _wreg_TMR1 AB W. MOV
	\ enable as we require
	03 # D0 MOV
	D0 _wreg_TMR1 AB W. MOV


	_#finished_setup_timer # D0 MOV
	D0 %port_init_where AB MOV

See DCR for further disscussion. 

 
	_#dcr_syncronous_mode
	_#dcr_refresh_timing   +
	_#dcr_refresh_count    + # D0 MOV
	D0 _wreg_DCR AB W. MOV

See DACRx for further disscussion. 

 
	_#sdram0_base
	_#dacrx_CASL            + \ Column address strobe latency 01
	_#dacrx_CBM             + \ Command and bank mux address line 22 and up
	_#dacrx_PM              + \ consinuous page mode
	_#dacrx_PS              + # D0 MOV \ Port size 32 bit
	D0 _lreg_DACR0 AB MOV

See DACRx for further disscussion. 

 
\	_#sdram1_base
\	_#dacrx_CASL            + \ Column address strobe latency 01
\	_#dacrx_CBM             + \ Command and bank mux address line 22 and up
\	_#dacrx_PM              + \ continuous page mode
\	_#dacrx_PS              + # D0 MOV \ Port size 32 bit
\	D0 _lreg_DACR1 AB MOV

See DMRx for further disscussion. 

 
	_#dmrx_address_mask
	_#dmrx_addr_modifiers +
	_#dmrx_valid + # D0 MOV
	D0 _lreg_DMR0 AB MOV

See DMRx for further disscussion. 

 
\	_#dmrx_address_mask
\	_#dmrx_addr_modifiers +
\	_#dmrx_valid + # D0 MOV
\	D0 _lreg_DMR1 AB MOV

These 5 registers complete the MCF5307 SDRam register setup phase.

Wait 100usecs. This can be generated in whatever manner desired but as CPU timeing is now very complex we have set up a timer for non interrupt operation and are about to poll the count. 

 
	

	
	
	0 # D0 MOV
	BEGIN
		_wreg_TCN1 AB D0 W. MOV
		\ COLDFORTH supports # as a decimal number indicator
		#4500 # D0 CMP
	GT UNTIL


	_#finished_first_wait # D0 MOV
	D0 %port_init_where AB MOV

Issue a "pre-charge all" command by setting the IP bit in the DACRx register to a one and then accessing any memory location in the associated SDRam. 

 
	\ bank 0
	_lreg_DACR0 AB D0 MOV
	_#dacrx_IP  # D0 OR    \ Initiate precharge all
	D0 _lreg_DACR0 AB MOV
	D0 _#sdram0_base AB MOV
	
	\ bank 1
\	_lreg_DACR1 AB D0 MOV
\	_#dacrx_IP  # D0 OR    \ Initiate precharge all
\	D0 _lreg_DACR1 AB MOV
\	D0 _#sdram1_base AB MOV

	\ wait until finished
	\ This should be a very short wait
	BEGIN
		_lreg_DACR1 AB D0 MOV
		_#dacrx_IP # D0 AND
	EQ UNTIL

	
	_#finished_precharge # D0 MOV
	D0 %port_init_where AB MOV

On completion of the pre-charge command the SDRam enters an idle state.

Enable refresh by setting the RE bit in the DACRx register to a one. 

 
	\ bank 0
	_lreg_DACR0 AB D0 MOV
	_#dacrx_RE  # D0 OR    \ Initiate refresh
	D0 _lreg_DACR0 AB MOV

	\ bank 1
\	_lreg_DACR1 AB D0 MOV
\	_#dacrx_RE  # D0 OR    \ Initiate refresh
\	D0 _lreg_DACR1 AB MOV

Once the Refresh commands have been enabled wait for at least eight refresh cycles to be completed ( user's manual 11.6.2.1.2), 2 cycles ( page 8 MT48L4M16A2 data sheets). The time taken for a refresh cycle is dependent on the value written to DCR . We have the value set for a refresh cycle every 15.28 usec.

Wait 15.28 * 3 = 45.84 usec, make it 100usec. 

 
	\ disable timer
	0 # D0 MOV
	D0 _wreg_TMR1 AB W. MOV
	\ enable as we require
	03 # D0 MOV
	D0 _wreg_TMR1 AB W. MOV
	BEGIN
		_wreg_TCN1 AB D0 W. MOV
		\ COLDFORTH supports # as a decimal number indicator
		#4500 #  D0 CMP
	GT UNTIL


	_#finished_refresh_wait # D0 MOV
	D0 %port_init_where AB MOV

The mode

If you set IMRS in _lreg_DACRx you can write to the SDRAM mode register. The value written depends on the address present on the address bus when the ram is next written to after IMRS is set. The address is not multiplexed (section 11.6.2.1.3). So you have to work out the value you want written and then work out which coldfire address lines you need active to put the value on the sdram address lines.

Lets work out the value first.

Sdram Address PinColdfire Address PinCommentvalue
015burst length 0(1)0
114burst length 10
213burst length 20
312Burst type(2)0
411CAS latency(3)0
510CAS latency1
69CAS latency0
717Operating Mode(4)0
818Operating mode0
919Write burst type(5)1
1021Reserved0
1120Reserved0

(1)Burst length is set to 1 as required section 11.6.2.1.3 of user's manual.
(2)Burst is not used, value should not matter.
(3)Bus running at 45 mHz 2 cycles is enough.
(4)Only one mode defined.
(5)0 or 1 should work. Set to 1

So the the value to write is 0x220

Now the translation. We need to set A5 and A9 on the chip, the address isn't multiplexed. write 80400. That is A10 and A19 on the coldfire. 

 
	\ bank 0
	_lreg_DACR0 AB D0 MOV
	_#dacrx_IMRS # D0 OR  \ Initiate mode register set
	D0 _lreg_DACR0 AB MOV
	\ Value written doesn't matter, the address does.
	D0 _#sdram0_base 80400 + AB MOV 

	
	\ bank 1
\	_lreg_DACR1 AB D0 MOV
\	_#dacrx_IMRS # D0 OR  \ Initiate mode register set
\	D0 _lreg_DACR1 AB MOV
\	\ value written doesn't matter, the address does.
\	D0 _#sdram1_base 80400 + AB MOV 
	
	\ finished sdram init 
	_#finished_sram_init # D0 MOV
	D0 %port_init_where AB MOV

The dram is ready to run. Wasn't too hard now was it.

Now to test it. Basic read and write 

 
	\ Can we write zero to bank 0?
	0 # D0 MOV
	D0 _#sdram0_base AB MOV
	_#sdram0_base AB D0 MOV NE IF

		0x2700 # STOP
	THEN

	_#finished_zero_write0 # D0 MOV
	D0 %port_init_where AB MOV


	\ Can we write -1 to bank 0?
	-1 # D0 MOV
	D0 _#sdram0_base AB MOV
	_#sdram0_base AB D0 MOV

Write value read back so fault can be looked at if it occures 

 
	D0 %port_init_where 4 + AB MOV
	-1 # D0 CMP NE IF

		0x2700 # STOP
	THEN

	_#finished_one_write0 # D0 MOV
	D0 %port_init_where AB MOV

The byte operations bank0 

 
	87 # D0 MOV
	D0 _#sdram0_base AB B. MOV
	_#sdram0_base AB D0 MOV
	0x87FFFFFF # D0 CMP NE IF
		0x2700 # STOP
	THEN

	\ Byte operations work bank0 
	_#finished_byte_op0a # D0 MOV
	D0 %port_init_where AB MOV

	65 # D0 MOV
	D0 _#sdram0_base 1+ AB B. MOV
	_#sdram0_base AB D0 MOV
	0x8765FFFF # D0 CMP NE IF
		0x2700 # STOP
	THEN
	\ Byte operations work bank0 
	_#finished_byte_op0b # D0 MOV
	D0 %port_init_where AB MOV

	43 # D0 MOV
	D0 _#sdram0_base 2 + AB B. MOV
	_#sdram0_base AB D0 MOV
	0x876543FF # D0 CMP NE IF
		0x2700 # STOP
	THEN
	\ Byte operations work bank0 
	_#finished_byte_op0c # D0 MOV
	D0 %port_init_where AB MOV

	21 # D0 MOV
	D0 _#sdram0_base 3 + AB B. MOV
	_#sdram0_base AB D0 MOV
	0x87654321 # D0 CMP NE IF
		0x2700 # STOP
	THEN

	\ Byte operations work bank0 
	_#finished_byte_op0d # D0 MOV
	D0 %port_init_where AB MOV

Ok now we have to test the whole thing, to keep the startup time reasonable, this things has to perform, so we enable cache. 

 
	\ Prom cache
	\ set ACR1
	_#acr1_address_mask
	_#acr1_address_base +
	_#acr1_enable + 
	_#acr1_SFIELD +
	_#acr1_CM  + # D0 MOV
	D0 ACR1 MOV

	\ clear the cache
	_#cacr_CINVA 
	_#cacr_DCM + # D0 MOV
	D0 CACR MOV

	\ enable the cache
	_#cacr_EC
	_#cacr_DCM + # D0 MOV
	D0 CACR MOV

Can we set the memory sub system to AAAAAAAA. 

 
	_#par_value # D0 MOV
	D0 _wreg_PAR AB W. MOV
	_#paddr_value # D0 MOV
	D0 _wreg_PADDR AB W. MOV
	_wreg_PADAT AB D0 W. MOV
	_#restart_method_bits # D0 AND
	_#base_restart # D0 CMP EQ W. IF

		
		_#sdram0_base # A0 MOV
		_#sdram0_size # D0 MOV
		0xAAAAAAAA # D1 MOV
		0 # D3 MOV
		BEGIN
			D1 A0 ) MOV
			D1 D3 ADD
			A0 )+ D3 SUB 
			4 # D0 SUB
		EQ UNTIL	
		D3 TST NE IF

				0x2700 # STOP
		THEN

		_#finished_AAAAAAAA_0 # D0 MOV
		D0 %port_init_where AB MOV

Can we set the memory sub system to 55555555. 

 

		_#sdram0_base # A0 MOV
		_#sdram0_size # D0 MOV
		0x55555555 # D1 MOV
		0 # D3 MOV
		BEGIN
			D1 A0 ) MOV
			D1 D3 ADD
			A0 )+ D3 SUB 
			4 # D0 SUB
		EQ UNTIL	
		D3 TST NE IF
	
				0x2700 # STOP
		THEN


		_#finished_55555555_0 # D0 MOV
		D0 %port_init_where AB MOV

Can we set sdram to its address in ascending order 

 

		_#sdram0_base # A0 MOV
		_#sdram0_size 2 / # D0 MOV
		BEGIN
			A0 A0 )+ MOV
			4 # D0 SUB
		EQ UNTIL
		
		_#sdram0_base _#sdram0_size 2 / + # A0 MOV
		A0 D1 MOV 4 # D1 ADD
		_#sdram0_size 2 / # D0 MOV
		BEGIN
			D1 A0 )+ MOV
			4 # D1 ADD
			4 # D0 SUB
		EQ UNTIL
		
			
		_#sdram0_base # A0 MOV
		_#sdram0_size 2/  # D0 MOV

		0 # D3 MOV
		BEGIN
			A0 D3 ADD
			A0 )+ D3 SUB 
			4 # D0 SUB
		EQ UNTIL	

		_#sdram0_base _#sdram0_size 2 / + # A0 MOV
		A0 D1 MOV 4 # D1 ADD
		_#sdram0_size 2 / # D0 MOV
		BEGIN
			D1 D3 ADD
			A0 )+  D3 SUB
			4 # D1 ADD
			4 # D0 SUB
		EQ UNTIL


		D3 TST NE IF

				0x2700 # STOP
		THEN
		_#finished_up_address_0 # D0 MOV
		D0 %port_init_where AB MOV

Can we set the sdram to its address in decending order 

 

		_#sdram0_base _#sdram0_size + # A0 MOV
		_#sdram0_size # D0 MOV
		BEGIN
			4 # A0 SUB
			A0 A0 ) MOV
			4 # D0 SUB
		EQ UNTIL	
		_#sdram0_base # A0 MOV
		_#sdram0_size # D0 MOV
		0 # D3 MOV
		BEGIN
			A0 D3 ADD
			A0 )+ D3 SUB 
			4 # D0 SUB
		EQ UNTIL	

		D3 TST NE IF

			0x2700 # STOP
		THEN

		_#finished_down_address_0 # D0 MOV
		D0 %port_init_where AB MOV
	
	THEN

I think we have to say the dynamic ram is ok. Set it to zero. 

 

	_#sdram0_base # A0 MOV
	_#sdram0_size # D0 MOV
	0 # D1 MOV
	BEGIN
		D1 A0 )+ MOV
		4 # D0 SUB
	EQ UNTIL

We now need to copy the boot code into the sdram. 

 

	_#boot_flash_base # A0 MOV
	_#sdram0_base # A1 MOV
	_#boot_flash_size # D0 MOV
	BEGIN
		A0 )+ A1 )+ MOV
		4 # D0 SUB
	EQ UNTIL

	_#finished_copied_boot # D0 MOV
	D0 %port_init_where AB MOV

We now have to flush the cache. There are two ways of doing this. We can use the cache flush instructions, or two we can copy data into a cached area. If we we look at the above copy we ended at the top of the copy area. All we have to do is copy to the bottom of the copy area. We can do this is steps of _#cache_line_size bytes. 

 
	_#sdram0_base # A0 MOV
	_#cache_size # D0 MOV
	BEGIN
		A0 ) A0 ) MOV
		_#cache_line_size # A0 ADD
		_#cache_line_size # D0 SUB
	EQ UNTIL

Enable caching dynamic ram 

 


	_#acr0_address_mask
	_#acr0_address_base +
	_#acr0_enable + 
	_#acr0_SFIELD +
	_#acr0_CM  + # D0 MOV
	D0 ACR0 MOV

And jump to the start routine, this is now in dynamic memory. 

 
	_start_up AB JMP

Change the address so it is a boot prom reference. patch it into the start of the boot prom. 

 
	HOST
	HERE   
	_prom_kernel_start org   0 t,  _boot_to_sdram _#sdram0_base - _#boot_flash_base + t,    
	org
./version081/bvp5501_constants.html0100777000000000000000000015167407300314346015741 0ustar rootroot COLDFORTH KERNEL license

Base for baud rate and timer calculations. 

 
	#45000000 CONSTANT _#bus_clock

BCM550 Memory map

Very early in the startup routine we test the dynamic ram. To have this happen in a resonable time the boot prom needs to be cached. The minimum cache size is 16 meg. So the boot prom is mapped into a 16 meg region at the start of memory. The rest of the memory areas follow from there.

From To Size Comment
0x00000000 0x07FFFF 0x80000 Boot prom
0x01000000 0x1FFFFF 0x200000 Application flash
0x02400000 0x08FFFF 0x80000 Synch static memory
0x02600000 - - Bank memory switch
0x02800000 - - Hardware function
0x02A00000 - - Nram
0x02C00000 0x07FFFF 0x80000 Dual port memory
0x02E00000 0x00FFFF 0x10000 function see additional table
0x03000000 0x0F00FFF0x1000 Modules base address register, any 4kbyte boundry
0x03080000 0x0F00FFF0x1000 Internal ram
0x100000000x10FFFFFF0x1000000DRAM1

Chip select 0, boot flash

 
	.S .( start MCF5307_constants.html)
	$00000000 CONSTANT _#boot_flash_base
	$00080000 CONSTANT _#boot_flash_size

Chip select 1, application flash

 
	$01000000 CONSTANT _#application_flash_base
	$00200000 CONSTANT _#application_flash_size

Chip select 2 -> 7

 
	$02000000 CONSTANT _#csbar  \ chip select base address register value

Chip select 2, synchronious memory

 
	$00400000 _#csbar + CONSTANT _#Synch_static_ram_base	
	$00080000           CONSTANT _#Synch_static_ram_size

Chip select 3, bank select memory

There are four banks the last is dealt with by the kernel. The other three are dealt with by the application. 

 
	$00618000 _#csbar + CONSTANT  _#bank_ram_base	
	$008000             CONSTANT  _#bank_ram_size

Chip select 6, RTI1000 duel port memory

 
	$00C00000 _#csbar + CONSTANT _#RTI1000_dual_port_base	
	$00004000           CONSTANT _#RTI1000_dual_port_size

Chip select 7, function data

 
	$00E00000 _#csbar +  CONSTANT _#function_data_base
	$00000040           CONSTANT _#function_data_size

Dynamic memory

 
	_prom_kernel_start CONSTANT _#sdram0_base
	$01000000 CONSTANT _#sdram0_size 

	_#sdram0_base CONSTANT _#start_dynamic
	$11000000 CONSTANT _#end_dynamic

MBAR

MBAR ( Module Base Address Register) is set with the code: 

 
#mba _#mbar_valid_bit + #  D0   MOV
D0      MBAR MOV

Once the MBA is set the registers are located in a specific spot in memory. 

 
	$03000000 CONSTANT #mba
		\ set to zero on a reset, must be set to one for access
		\ to system integration module
		$00000001 CONSTANT _#mbar_valid_bit

		\ every address has an address modifier associated 
		\ with it. Setting the following bits [revent access
		\ to the system modules in particular address spaces.
		\ In this system access is allowed in all spaces.
		$00000002 CONSTANT _#mbar_block_user_data
		$00000004 CONSTANT _#mbar_block_user_code
		$00000008 CONSTANT _#mbar_block_system_data
		$00000010 CONSTANT _#mbar_block_system_code
		$00000020 CONSTANT _#mbar_block_c/i
		$00000040 CONSTANT _#mbar_allow_alternate

RAMBAR

Base address of the on board static ram. Set with the instruction:

 
D0 RAMBAR MOV

Section 6.3.4 talks about reducing power consumption, in our case the on board ram is not used for code so we block code accesses 

 
	$03080000           CONSTANT _#rambar_base     \ coldfire ram
		$00000001 CONSTANT _#rambar_valid
		$00000002 CONSTANT _#rambar_block_user_data
		$00000004 CONSTANT _#rambar_block_user_code
		$00000008 CONSTANT _#rambar_block_system_data
		$00000010 CONSTANT _#rambar_block_system_code
		$00000020 CONSTANT _#rambar_block_c/i
		$00000100 CONSTANT _#rambar_write_protect
	$1000 CONSTANT _#rambar_size

CACHE

The memory space can be divided up into three modes. This system has a lot of memory areas devoted to I/O, the default mode shall be suitable for that type of operation. That is non-cachable. Imprecise is the default mode. If a location access resets an interrupt it must be written to. Read imprecise mode allows multiple reads under some circumstances. Oh how I wish for the simple days, when computers did what they where told.

CACR ( Cache Control register) 

 
	$80000000 CONSTANT _#cacr_EC    \ Enable cache
\	$20000000 CONSTANT _#cacr_ESB   \ We don't enable the store buffer, there is no code
	                               \ in non cachable areas
\	$10000000 CONSTANT _#cacr_DPI   \ Disable CPUSHL invalidate. Don't use the instruction
	                               \ don't care
\	$08000000 CONSTANT _#cacr_HLCK  \ don't use.
	$01000000 CONSTANT _#cacr_CINVA \ cache invalidate all, needed to get started
\	$00000400 CONSTANT _#cacr_DNFB  \ All code is cached
	$00000300 CONSTANT _#cacr_D