├── .gitignore ├── LICENSE ├── Makefile ├── README ├── ADDENDUM ├── README └── quotes ├── extend ├── src ├── examples │ ├── bench │ │ ├── bench.f │ │ ├── benchie.f │ │ ├── bits.f │ │ ├── fib.f │ │ ├── goly.f │ │ ├── kcbench.f │ │ ├── litcon.f │ │ ├── nest.f │ │ └── primes.f │ ├── bot │ │ ├── bot.f │ │ ├── io.f │ │ ├── irc.f │ │ └── numeric.f │ ├── case.f │ ├── defers.f │ ├── dots │ │ ├── shapes.f │ │ ├── sintab.f │ │ └── wmdots.f │ ├── itowers.f │ ├── mmtest.f │ ├── mmtest │ │ ├── display.f │ │ ├── init.f │ │ ├── mmtest.f │ │ ├── run.f │ │ └── vars.f │ ├── pong.f │ ├── revbits.f │ ├── showargs.f │ ├── sigtst.f │ ├── test.f │ ├── towers.f │ └── wintst.f ├── ext │ ├── args.f │ ├── case.f │ ├── datetime │ │ ├── date.f │ │ ├── localtime.f │ │ └── timer.f │ ├── debug │ │ ├── debug.f │ │ ├── info.f │ │ ├── init.f │ │ ├── keys.f │ │ ├── see.f │ │ ├── stackdisp.f │ │ ├── utils.f │ │ └── window.f │ ├── dents.f │ ├── env.f │ ├── file.f │ ├── forget.f │ ├── fsave.f │ ├── header.f │ ├── hello.f │ ├── history.f │ ├── init.f │ ├── list.f │ ├── loops.f │ ├── ls.f │ ├── macros │ │ ├── inline.f │ │ └── macros.f │ ├── memman │ │ ├── alloc.f │ │ ├── dealloc.f │ │ ├── heap.f │ │ ├── info.f │ │ ├── memory.f │ │ └── util.f │ ├── message.f │ ├── number.f │ ├── resolver.f │ ├── rnd.f │ ├── see │ │ ├── cond.f │ │ ├── disp.f │ │ ├── see.f │ │ └── utils.f │ ├── sockets.f │ ├── stacks.f │ ├── status.f │ ├── struct.f │ ├── tail.f │ ├── terminal │ │ ├── color.f │ │ ├── keys.f │ │ ├── term.f │ │ ├── terminfo.f │ │ ├── tformat.f │ │ └── twinch.f │ ├── tty.f │ ├── tui │ │ ├── border.f │ │ ├── menu.f │ │ ├── menuctl.f │ │ ├── menudsp.f │ │ ├── scrdsp.f │ │ ├── screen.f │ │ ├── tui.f │ │ ├── window.f │ │ └── windsp.f │ ├── utf8.f │ ├── utils.f │ ├── utils │ │ ├── getuid.f │ │ ├── ioctl.f │ │ ├── seaio │ │ │ ├── seaio.f │ │ │ ├── structures.f │ │ │ └── test.f │ │ ├── serial.f │ │ └── stat.f │ ├── variable.f │ ├── vocabs.f │ └── words.f ├── kernel │ ├── Makefile │ ├── comma.s │ ├── comment.s │ ├── compile.s │ ├── double.s │ ├── exec.s │ ├── expect.s │ ├── find.s │ ├── fload.s │ ├── header.s │ ├── init.s │ ├── interpret.s │ ├── io.s │ ├── ldscript │ ├── logic.s │ ├── loops.s │ ├── macros.s │ ├── math.s │ ├── memory.s │ ├── number.s │ ├── parse.s │ ├── rehash.s │ ├── reloc.s │ ├── scan.s │ ├── stack.s │ ├── syscalls.s │ ├── vocabs.s │ └── x4.asm └── x4.f └── x4.rcf /.gitignore: -------------------------------------------------------------------------------- 1 | *.sublime* 2 | kernel.com 3 | src/kernel.o 4 | x4 5 | x4_old 6 | *.lst 7 | *~ 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 Mark Manning 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | 3 | all: linux 4 | 5 | linux: 6 | cd src/kernel/ && make 7 | 8 | clean: 9 | @rm -f src/kernel.o 10 | @rm -f src/kernel.lst 11 | @rm -f kernel.com 12 | @rm -f x4 13 | -------------------------------------------------------------------------------- /README/ADDENDUM: -------------------------------------------------------------------------------- 1 | 2 | Addendum to the license of the x4 Compiler 3 | -------------------------------------------------------------------------- 4 | 5 | Unless otherwise stated, the entire sources for the x4 compiler are 6 | released under a modifed LGPL licence allowing you to use x4 to create 7 | commercial applications without requiring that you release your source 8 | code. 9 | 10 | This means that as long as you compiled your application using THIS 11 | compiler none of your applications sources shall be subject to any part of 12 | any variaton of the GPL licence. If however you take part of this 13 | compiler and use it wihtin your own compiler without permission then your 14 | compiler in it's entirety shall be coverd by MY license. 15 | 16 | This applies to any part of the x4 compiler sources other than those which 17 | might be overed by "acceptable use". For example, I cannot in good faith 18 | claim any copyright on the forth word ?: even though I have never seen 19 | it's like in any other Forth compiler. If you place a definition for ?: 20 | or other such words within your compiler then that would be considerd an 21 | acceptable use. I claim no copyright on any individual Forth 22 | definitions, even the ones I think I invented. 23 | 24 | If however you take the entire curses module or the memory manager or some 25 | other such module in part or in full without prior permission then this 26 | shall not be coverd by acceptable use and you shall be required to release 27 | 100% of your sources under my modified LGPL license. 28 | 29 | Permission to use any module within the x4 source tree is hereby granted 30 | to Forth Inc and to Ron Oliver. Though... I doubt either will :) 31 | 32 | ----------------- 33 | Mark I Manning IV 34 | ----------------- 35 | 36 | ========================================================================== 37 | -------------------------------------------------------------------------------- /README/quotes: -------------------------------------------------------------------------------- 1 | 2 | Some things ive seen in /usr/games/fortune that remind me if x4 :) 3 | 4 | ------------------------------------------------------------------------ 5 | 6 | ... it is easy to be blinded to the essential uselessness of them by the 7 | sense of achievement you get from getting them to work at all. In other 8 | words... their fundamental design flaws are completely hidden by their 9 | superficial design flaws. 10 | -- The Hitchhiker's Guide to the Galaxy, on the products 11 | of the Sirius Cybernetics Corporation. 12 | 13 | ----- 14 | 15 | No extensible language will be universal. 16 | -- T. Cheatham 17 | 18 | ----- 19 | 20 | Cruickshank's Law of Committees: 21 | If a committee is allowed to discuss a bad idea long enough, it 22 | will inevitably decide to implement the idea simply because so 23 | much work has already been done on it. 24 | 25 | (e.g. ans forth) 26 | 27 | ----- 28 | 29 | C is quirky, flawed, and an enormous success 30 | -- Dennis M. Ritchie 31 | 32 | ----- 33 | 34 | If it has syntax, it isn't user friendly 35 | 36 | ----- 37 | 38 | To follow foolish precedents, and wink 39 | With both our eyes, is easier than to think. 40 | - William Cowper 41 | 42 | ----- 43 | 44 | Putt's Law: 45 | Technology is dominated by two types of people: 46 | Those who understand what they do not manage. 47 | Those who manage what they do not understand. 48 | 49 | ----- 50 | 51 | Magic is always the best solution -- especially reliable magic. 52 | 53 | ----- 54 | 55 | The finest eloquence is that which gets things done 56 | 57 | ----- 58 | 59 | If the code and the comments disagree, then both are probably wrong. 60 | -- Norm Schryer 61 | 62 | ----- 63 | 64 | Unix was not designed to stop you from doing stupid things, because that 65 | would also stop you from doing clever things. 66 | -- Doug Gwyn 67 | 68 | dito forth 69 | 70 | ----- 71 | 72 | Kites rise highest against the wind -- not with it. 73 | -- Winston Churchill 74 | 75 | ----- 76 | 77 | Unix: Some say the learning curve is steep, but you only have to climb it once. 78 | -- Karl Lehenbauer 79 | 80 | ---- 81 | -------------------------------------------------------------------------------- /extend: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | mv -f x4 x4_old 3 | printf "fload src/x4.f\n" | ./kernel.com 4 | -------------------------------------------------------------------------------- /src/examples/bench/bench.f: -------------------------------------------------------------------------------- 1 | \ bench.f - lets just waste some time and computing power :P 2 | \ ------------------------------------------------------------------------ 3 | 4 | vocabulary benchmark benchmark definitions 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | fload src/bench/bits.f 9 | fload src/bench/fib.f 10 | fload src/bench/litcon.f 11 | fload src/bench/goly.f 12 | fload src/bench/primes.f 13 | fload src/bench/nest.f 14 | 15 | \ ------------------------------------------------------------------------ 16 | 17 | : bench 18 | cr timer-reset 19 | bit-bench 20 | fib-bench 21 | lc-bench 22 | goly-bench 23 | prime-bench 24 | nest-bench 25 | cr ." all benchmarks ran in " 26 | .elapsed cr ; 27 | 28 | \ ------------------------------------------------------------------------ 29 | 30 | bench 31 | 32 | \ ======================================================================== 33 | -------------------------------------------------------------------------------- /src/examples/bench/benchie.f: -------------------------------------------------------------------------------- 1 | \ benchie.f 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading benchie.f ) 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | \ tForth (20 MHz T8): 196 bytes 0.198 sec 9 | \ iForth (33 MHz '386): 175 bytes 0.115 sec 10 | \ iForth (40 MHz '486DLC): 172 bytes 0.0588 sec 11 | \ iForth (66 MHz '486): 172 bytes 0.0323 sec 12 | \ RTX2000: 89 bytes 0.098 sec (no Headers) 13 | \ 8051 ANS Forth (12 MHz 80C535): 126 bytes 15,8 sec (met uservariabelen) 14 | 15 | \ just to show exactly how much im competing with these guys :) 16 | 17 | \ x4 (550 MHz K63): 191 bytes 1.663 (no headers) - my worst case 18 | \ I have the fastest box and the slowest results other than the 8051 19 | 20 | here 21 | 22 | 5 const five \ redundant realy 5 is already a const in x4 23 | 0 var bvar 24 | 25 | : bench 26 | 2560 0 27 | do 28 | 1 29 | begin 30 | dup swap dup rot drop 1 and 31 | if 32 | five + 33 | else 34 | 1- 35 | then 36 | !> bvar 37 | bvar dup $100 and 38 | until 39 | drop 40 | loop ; 41 | 42 | cr .( Size: ) here swap - . .( bytes.) 43 | 44 | : test cr ." time*10: " timer-reset bench .elapsed ; 45 | 46 | \ ======================================================================== 47 | -------------------------------------------------------------------------------- /src/examples/bench/bits.f: -------------------------------------------------------------------------------- 1 | \ bits.f - x4 bit counting benchmark 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading bits.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | defer bits 9 | 10 | \ ------------------------------------------------------------------------ 11 | 12 | : (bits1) ( n1 --- n2 ) 13 | 0 swap \ prime result - get n1 at top 14 | begin 15 | tuck \ keep copy of n1 16 | while \ while n1 is not zero do 17 | 1+ swap \ increment bitcount 18 | dup 1- and \ and n1 with n1-1 (removes 1 bit from n1) 19 | repeat 20 | nip ; \ discard copy 21 | 22 | \ i actualy tried to use this algorithm on a contract once where i had to 23 | \ know the number of bits in a byte but my boss wouldnt let me use it 24 | \ because he couldnt believe it would work no matter how much i explained 25 | \ it (duh) - managers realy should trust their coders to know better than 26 | \ they do what is and what is not the best solution! 27 | 28 | \ ------------------------------------------------------------------------ 29 | 30 | $01010101 constant magic \ define this as const see difference 31 | 32 | : (bits2) 33 | 0 swap 34 | dup magic and rot + swap 2/ 35 | dup magic and rot + swap 2/ 36 | dup magic and rot + swap 2/ 37 | dup magic and rot + swap 2/ 38 | dup magic and rot + swap 2/ 39 | dup magic and rot + swap 2/ 40 | dup magic and rot + swap 2/ 41 | magic and + 42 | 43 | split + 44 | dup $ff and swap 45 | 8 u>> + ; 46 | 47 | \ ------------------------------------------------------------------------ 48 | \ run selected benchmark 10,000,000 times 49 | 50 | : do-bits 51 | timer-reset 52 | 10000000 0 53 | do 54 | i bits drop 55 | loop 56 | .elapsed ; 57 | 58 | \ ------------------------------------------------------------------------ 59 | 60 | : bit-bench 61 | cr ." bits 1 " ['] (bits1) is bits do-bits 62 | cr ." bits 2 " ['] (bits2) is bits do-bits ; 63 | 64 | \ (bits1) runs in 1:40 on my amd k6-3/550 laptop 65 | \ (bits2) runs in 3:07 on same 66 | 67 | \ ======================================================================== 68 | -------------------------------------------------------------------------------- /src/examples/bench/fib.f: -------------------------------------------------------------------------------- 1 | \ fib.f - x4 fibonacci benchmark words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading fib.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | 9000000 var itters \ 9 million 9 | 10 | 0 var counter 11 | 12 | \ ------------------------------------------------------------------------ 13 | \ removed from the kernel because i discourage its use and this example 14 | \ is the only place i use it 15 | 16 | : recurse 17 | last name> , ; ; foot in self shoot 18 | 19 | \ ------------------------------------------------------------------------ 20 | \ the recursive method - this we call once not 9 milion times :) 21 | 22 | \ this word recurses on itself one hundred and thirteen million times 23 | \ to calculate the 40th fib (bleh) 24 | 25 | : fib1 ( n1 --- ) 26 | dup 1 > 27 | if 28 | dup 1- recurse 29 | swap 2- recurse 30 | + 31 | then ; 32 | 33 | \ ------------------------------------------------------------------------ 34 | \ this code is more proof that anything you can do with recursion 35 | \ can be done better without. 36 | 37 | 1 var f1 38 | 0 var f2 39 | 40 | : fib2 41 | off> f2 42 | 1 !> f1 43 | 1 44 | ?do 45 | f2 f1 + 46 | f1 !> f2 47 | !> f1 48 | loop f1 ; 49 | 50 | \ ------------------------------------------------------------------------ 51 | \ this is my version of the above itterative method 52 | 53 | : fib3 54 | 0 1 rot 1 55 | ?do 56 | tuck + 57 | loop nip ; 58 | 59 | \ ------------------------------------------------------------------------ 60 | 61 | : (fib4) tuck + ; 62 | : fib4 1 1 rot 1- rep (fib4) drop ; 63 | 64 | \ ------------------------------------------------------------------------ 65 | 66 | : fib-bench 67 | cr ." fib 1 " timer-reset 40 fib1 drop .elapsed 68 | cr ." fib 2 " timer-reset itters 0 do 40 fib2 drop loop .elapsed 69 | cr ." fib 3 " timer-reset itters 0 do 40 fib3 drop loop .elapsed 70 | cr ." fib 4 " timer-reset itters 0 do 40 fib4 drop loop .elapsed ; 71 | 72 | \ fib1 rubs in 4:06 on my k6-3/550 73 | \ fib2 runs in 17:56 74 | \ fib3 runs in 0:32 75 | 76 | \ ======================================================================== 77 | -------------------------------------------------------------------------------- /src/examples/bench/kcbench.f: -------------------------------------------------------------------------------- 1 | \ benchmark by kc5tja in #forth 2 | \ ------------------------------------------------------------------------ 3 | 4 | create v 16384 allot 5 | 6 | m: v+ 1 over +! cell+ ;m 7 | m: +1 v+ v+ v+ v+ v+ v+ v+ v+ v+ v+ v+ v+ v+ v+ v+ v+ ;m 8 | m: +2 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 ;m 9 | : +3 v +2 +2 +2 +2 +2 +2 +2 +2 +2 +2 +2 +2 +2 +2 +2 +2 drop ; 10 | : t' begin dup 0= if exit then +3 1- again drop ; 11 | : t 16777216 t' ; 12 | 13 | : test timer-reset t .elapsed ; 14 | 15 | \ ======================================================================== 16 | -------------------------------------------------------------------------------- /src/examples/bench/litcon.f: -------------------------------------------------------------------------------- 1 | \ benchmark difference in execution speed between a literal and a constant 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading litcon.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | \ i would consider this to be the only realy usefull benchmark in this 9 | \ whole suite. it doesnt say how fast my forth is (its not fast) it tells 10 | \ you which method is better. variable/constant or var/const :) 11 | 12 | 0 constant c \ compiles a doconstant 13 | 0 const l \ compiles a (lit) 14 | 15 | \ ------------------------------------------------------------------------ 16 | \ b1 and b2 are identical in every respect except one uses c the other l 17 | 18 | : b1 timer-reset 100000000 0 do c drop loop .elapsed ; 19 | : b2 timer-reset 100000000 0 do l drop loop .elapsed ; 20 | 21 | \ ------------------------------------------------------------------------ 22 | 23 | : lc-bench 24 | cr 25 | ." constant " b1 cr \ 1:20 on my k6-3/550 26 | ." literals " b2 cr ; \ 0:07 on my k6-3/550 27 | 28 | \ ======================================================================== 29 | -------------------------------------------------------------------------------- /src/examples/bench/nest.f: -------------------------------------------------------------------------------- 1 | \ nest.f - x4 nest/unnest benchmark 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading nest.f ) cr 5 | 6 | \ this code was 'borrowed' from the linux eforth sources (snicker) 7 | 8 | \ ------------------------------------------------------------------------ 9 | \ levels of nesting 10 | 11 | : 1st noop noop ; 12 | : 2nd 1st 1st ; 13 | : 3rd 2nd 2nd ; 14 | : 4th 3rd 3rd ; 15 | : 5th 4th 4th ; 16 | : 6th 5th 5th ; 17 | : 7th 6th 6th ; 18 | : 8th 7th 7th ; 19 | : 9th 8th 8th ; 20 | : 10th 9th 9th ; 21 | : 11th 10th 10th ; 22 | : 12th 11th 11th ; 23 | : 13th 12th 12th ; 24 | : 14th 13th 13th ; 25 | : 15th 14th 14th ; 26 | : 16th 15th 15th ; 27 | : 17th 16th 16th ; 28 | : 18th 17th 17th ; 29 | : 19th 18th 18th ; 30 | : 20th 19th 19th ; \ 2 ^ 20 nest unnest pairs 31 | : 21st 20th 20th ; 32 | : 22nd 21st 21st ; 33 | : 23rd 22nd 22nd ; 34 | : 24th 23rd 23rd ; 35 | : 25th 24th 24th ; \ 2 ^ 25 = 32 million nest unnest pairs 36 | 37 | \ : 26th 25th 25th ; 38 | \ : 27th 26th 26th ; 39 | \ : 28th 27th 27th ; \ 256 million 40 | 41 | \ ------------------------------------------------------------------------ 42 | \ time 32 million nest unnest pairs 43 | 44 | : 32-million 45 | timer-reset \ start clock 46 | 25th 47 | .elapsed ; 48 | 49 | \ ------------------------------------------------------------------------ 50 | \ this takes 4.230 seconds on my amd k6-3/550 51 | 52 | : nest-bench 53 | cr ." nesting: " 32-million ; 54 | 55 | \ ------------------------------------------------------------------------ 56 | \ time 1 million nest unnest pairs 57 | 58 | : 1-million 59 | timer-reset 25th .elapsed ; 60 | 61 | \ ======================================================================== 62 | -------------------------------------------------------------------------------- /src/examples/bench/primes.f: -------------------------------------------------------------------------------- 1 | \ primes.f - benchmark to find prime numbers (bleh :) 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading primes.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | create flags 40960 allot 9 | flags 40960 + constant e 10 | 0 var result 11 | 12 | \ ------------------------------------------------------------------------ 13 | 14 | : primes 15 | flags 40960 1 fill 16 | 0 3 e flags 17 | do 18 | i c@ 19 | if 20 | dup i + dup e u< 21 | if 22 | e swap 23 | do 24 | 0 i c! dup 25 | +loop 26 | else 27 | drop 28 | then 29 | swap 1+ swap 30 | then 31 | 2+ 32 | loop 33 | drop ; 34 | 35 | \ ------------------------------------------------------------------------ 36 | 37 | : prime-bench 38 | cr ." primes: " timer-reset 39 | 1000 0 do primes !> result loop 40 | result . ." primes found 1000 times in " .elapsed ; 41 | 42 | \ ======================================================================== 43 | -------------------------------------------------------------------------------- /src/examples/bot/bot.f: -------------------------------------------------------------------------------- 1 | \ bot.f - the x4 irc bot 2 | \ ------------------------------------------------------------------------ 3 | 4 | vocabulary irc-bot irc-bot definitions 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | 6667 const bot-port \ port to connect to irc on 9 | 10 | ip: bot-server 130.239.18.172. \ freenode.net 11 | \ ip: bot-server 205.252.46.98. \ undernet.org 12 | \ ip: bot-server 206.252.192.197. \ stealth.net 13 | \ ip: bot-server 127.0.0.1. \ localhost.org :) 14 | 15 | \ ip: bot-server 66.225.225.225. \ efnet.us 16 | 17 | \ ------------------------------------------------------------------------ 18 | \ list of comma seperated channels for bot to join 19 | 20 | create bot-channels \ channel list for bot to join 21 | ," #forth" \ ," #c1,#c2,#c3" 22 | 23 | \ ------------------------------------------------------------------------ 24 | \ bot login information 25 | 26 | create bot-user ," Forth +iwg Forth :do drop >in" 27 | create bot-nick ," [Forth]" 28 | 29 | \ you might want to remove the wg flags from the above default modes 30 | 31 | \ ------------------------------------------------------------------------ 32 | \ just a string to comapre input with to see if server is pinging us 33 | 34 | create sping \ server ping identifier 35 | ," PING :" 36 | 37 | \ ------------------------------------------------------------------------ 38 | \ include files 39 | 40 | fload src/examples/bot/io.f \ socket connect, read, write and mesg output 41 | fload src/examples/bot/irc.f \ irc protocol message parsing 42 | fload src/examples/bot/numeric.f \ handle server numerics 43 | 44 | \ ------------------------------------------------------------------------ 45 | 46 | : bot-quit 47 | bot" quit :abort" $22 bot-emit 48 | bot" Reality Strikes Again" 49 | $22 bot-emit 50 | bot-cr bye ; 51 | 52 | \ ------------------------------------------------------------------------ 53 | 54 | : ?bot-quit 55 | key? 0= ?exit 56 | key 'x' = 57 | if 58 | bot-quit 59 | then ; 60 | 61 | \ ------------------------------------------------------------------------ 62 | \ handle message based on its type 63 | 64 | : (do-message) ( --- ) 65 | -2 +!> #inbuff \ get rid of crlf 66 | bl inbuff #inbuff + c! \ put blank at end of inbuff 67 | 68 | inbuff raw-buff \ copy raw message to seperate buffer 69 | #inbuff cmove 70 | tokenize \ and tokenize the message 71 | 72 | msg-type number \ is the message type a valid number? 73 | ?: \ if (numeric) else .raw then 74 | numeric \ handle server numerics 75 | .raw ; \ handle privmsg and notice 76 | 77 | \ ------------------------------------------------------------------------ 78 | \ respond to a server ping 79 | 80 | : (sping) 81 | bot" PONG " \ reply with a pong with... 82 | inbuff #inbuff 6 /string \ extract ping id from source 83 | (bot-type) ; \ includes the crlf 84 | 85 | \ ------------------------------------------------------------------------ 86 | \ handle one message from irc server/client 87 | 88 | : do-message 89 | inbuff sping count comp \ is it a server ping? 90 | 0= 91 | ?: 92 | (sping) \ yes, reply to server ping 93 | (do-message) ; \ no its a server/user message, process it 94 | 95 | \ ------------------------------------------------------------------------ 96 | \ read and process one line of text from irc 97 | 98 | : (bot) 99 | bot-read \ read one line of data from bot socket 100 | #inbuff 0> \ any data recieved ? 101 | ?: 102 | do-message \ yes handle message 103 | bot-connect ; \ no - reconnect! 104 | 105 | \ ------------------------------------------------------------------------ 106 | \ bot main 107 | 108 | : bot 109 | cr bot-connect \ get connected! 110 | begin \ do forever (ish) 111 | ?bot-quit \ 'x' keypress kills bot 112 | bot-poll 113 | if 114 | (bot) 115 | then 116 | again ; 117 | 118 | \ ======================================================================== 119 | -------------------------------------------------------------------------------- /src/examples/bot/irc.f: -------------------------------------------------------------------------------- 1 | \ irc.f - x4 parse irc messages and split into component parts 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( Loading irc.f) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | 0 var >inbuff \ where were at in inbuff 9 | 10 | \ ------------------------------------------------------------------------ 11 | \ different component parts of an irc message 12 | 13 | 0 var msg-src \ server domain name or nick!user@host.com 14 | 0 var msg-type \ numeric, notice or privmsg 15 | 0 var victim \ target of message 16 | 0 var msg-body \ may or may not start with a : char (ugh) 17 | 0 var who \ nick from message source 18 | 0 var host \ host from message source 19 | 20 | \ ------------------------------------------------------------------------ 21 | 22 | create raw-buff 521 allot \ a copy of hbuff 23 | raw-buff 521 erase 24 | 25 | \ ------------------------------------------------------------------------ 26 | \ debug - display raw irc message 27 | 28 | : .raw 29 | raw-buff 30 | #inbuff type 31 | cr ; 32 | 33 | \ ------------------------------------------------------------------------ 34 | \ extract next space delimited token from bot input 35 | 36 | : bot-parse ( --- a1 ) 37 | inbuff #inbuff >inbuff \ get address of current pos in inbuff 38 | /string \ and # chars therein 39 | over -rot \ remember address of parsed token ( a1 ) 40 | 1 /string \ skip first character 41 | $20 scan drop \ find end of token 42 | over - 1- \ get length of token 43 | 2dup swap c! \ store length byte at start of token 44 | 1+ +!> >inbuff ; \ set current pos past token 45 | 46 | \ ------------------------------------------------------------------------ 47 | \ tokenise and interpret message recieved from irc 48 | 49 | \ split hbuff up into various counted strings 50 | 51 | : tokenize ( --- ) 52 | off> >inbuff 53 | 54 | bot-parse !> msg-src \ who sent the message 55 | bot-parse !> msg-type \ what sort of message is it 56 | bot-parse !> victim \ who is message aimed at 57 | 58 | incr> >inbuff ; \ point to start of possible message body 59 | 60 | \ ======================================================================== 61 | -------------------------------------------------------------------------------- /src/examples/bot/numeric.f: -------------------------------------------------------------------------------- 1 | \ numeric.f - x4 irc bot server numeric handler 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( Loading numeric.f) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ display contents of message stream from >inbuff 8 | 9 | : (.message) ( f --- t ) 10 | inbuff #inbuff >inbuff 11 | /string type cr 12 | drop true ; \ numeric was known 13 | 14 | \ ------------------------------------------------------------------------ 15 | \ welcome to irc numeric 16 | 17 | : .message ( f --- t ) 18 | incr> >inbuff \ scan past : at start of message 19 | (.message) ; 20 | 21 | \ ------------------------------------------------------------------------ 22 | \ recieved end of motd - make bot join channels 23 | 24 | : end_motd ( f --- t ) 25 | .message 26 | bot" JOIN " bot-channels bot-type 27 | bot-cr ; 28 | 29 | \ ------------------------------------------------------------------------ 30 | \ display channel topic on entry 31 | 32 | : .topic ." Topic for #" .message ; 33 | : .topic_by ." Set by " (.message) ; 34 | : .users ." Names for" .message ; 35 | 36 | \ ------------------------------------------------------------------------ 37 | 38 | : numeric ( n1 --- ) 39 | false swap \ assume unknown numeric 40 | case: 41 | 1 opt .message 42 | 2 opt .message 43 | 3 opt .message 44 | 4 opt (.message) 45 | 251 opt .message \ users online 46 | 252 opt (.message) \ operators online 47 | 254 opt (.message) \ channels formed 48 | 255 opt .message \ ison reply 49 | 332 opt .topic 50 | 333 opt .topic_by 51 | 335 opt .message 52 | 353 opt .users \ list chan users 53 | 366 opt .message \ end of names list 54 | 372 opt .message \ body of motd 55 | 375 opt .message \ start of motd 56 | 376 opt end_motd \ end of motd - bot joins channels 57 | 58 | 59 | \ 381 opt .message \ you are now an irc operator 60 | \ 382 opt .message \ re-hashing 61 | \ 433 opt .message \ make bot select alt nick here eventually 62 | \ 461 opt .message \ not enough parameters 63 | \ 462 opt .message \ you may not register 64 | \ 481 opt .message \ premission denied 65 | \ 512 opt .message \ no such gline 66 | ;case 67 | ?exit .raw ; 68 | 69 | \ ======================================================================== 70 | -------------------------------------------------------------------------------- /src/examples/case.f: -------------------------------------------------------------------------------- 1 | \ case.f - an example of how to use case: statements in x4 2 | \ ------------------------------------------------------------------------ 3 | 4 | vocabulary example example definitions 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | : .help 9 | ." Press 1, 2 or A thru Z (X quits) " cr cr ; 10 | 11 | \ ------------------------------------------------------------------------ 12 | 13 | : casea ." You pressed A" ; 14 | : caseb ." You pressed B" ; 15 | : casec ." You pressed C" ; 16 | : cased ." You pressed D" ; 17 | : casee ." You pressed E" ; 18 | : casef ." You pressed F" ; 19 | : caseg ." You pressed G" ; 20 | : caseh ." You pressed H" ; 21 | : casei ." You pressed I" ; 22 | : casej ." You pressed J" ; 23 | : casek ." You pressed K" ; 24 | : casel ." You pressed L" ; 25 | : casem ." You pressed M" ; 26 | : casen ." You pressed N" ; 27 | : caseo ." You pressed O" ; 28 | : casep ." You pressed P" ; 29 | : caseq ." You pressed Q" ; 30 | : caser ." You pressed R" ; 31 | : cases ." You pressed S" ; 32 | : caset ." You pressed T" ; 33 | : caseu ." You pressed U" ; 34 | : casev ." You pressed V" ; 35 | : casew ." You pressed W" ; 36 | : casey ." You pressed Y" ; 37 | : casez ." You pressed Z" ; 38 | : case1 ." You pressed 1" ; 39 | : case2 ." You pressed 2" ; 40 | 41 | : oopts ." Try 1, 2 or A thru Z (X quits) " ; 42 | 43 | \ ------------------------------------------------------------------------ 44 | 45 | \ note - there is no equiv of an endof - each opt in a case: structure 46 | \ must be a reference to a single seperate word. this is the only place 47 | \ thus far where x4 enforces good programming practices. 48 | \ 49 | \ case 50 | \ foo of xxx yyy zzz 100 0 do lotsa code here loop endof 51 | \ ... 52 | \ ... 53 | \ ... 54 | \ ... 55 | \ endcase 56 | \ 57 | \ the above code is just a huge blob of visually cluttered sphagetti code 58 | \ that is just another way todays forth coders fuck up their soruce - 59 | \ if you like coding this sort of crap then replace my case: with some 60 | \ other case construct and go tie yourself a gordian knot. bleh! 61 | 62 | \ ------------------------------------------------------------------------ 63 | 64 | : xcase 65 | cr .help 66 | begin 67 | key 68 | case: \ we are now in interpret mode 69 | 'a' opt casea \ nice - neat - clean - concice 70 | 'b' opt caseb \ no visual clutter - and faster than 71 | 'c' opt casec \ a series of nested if-else bullshit 72 | 'd' opt cased 73 | 'e' opt casee 74 | 'f' opt casef 75 | 'g' opt caseg 76 | 'h' opt caseh 77 | 'i' opt casei 78 | 'j' opt casej 79 | 'k' opt casek 80 | 'l' opt casel 81 | 'm' opt casem 82 | 'n' opt casen 83 | 'o' opt caseo 84 | 'p' opt casep 85 | 'q' opt caseq 86 | 'r' opt caser 87 | 's' opt cases 88 | 't' opt caset 89 | 'u' opt caseu 90 | 'v' opt casev 91 | 'w' opt casew 92 | 'x' opt exit 93 | 'y' opt casey 94 | 'z' opt casez 95 | '1' opt case1 96 | '2' opt case2 97 | dflt oopts \ default action when none of the above 98 | ;case 99 | cr 100 | again ; 101 | 102 | \ dflt and its vector are optional and can be placed anywhere between 103 | \ case: and ;case, even in the middle of the block of opts (yukk) 104 | 105 | \ ------------------------------------------------------------------------ 106 | \ the following shows how to create a turnkey application. 107 | 108 | \ : foo \ create an entry point for app 109 | \ case-example bye ; \ run main function then quit 110 | 111 | \ ' foo is quit \ patch quit to be our main entry point 112 | \ turnkey foo \ create turnkey executable called foo 113 | 114 | \ uncomment the aove 4 lines then have x4 interpret this file. it 115 | \ will save out an executable called foo that you can run on any x86 116 | \ based linux box even if x4 isnt installed there. 117 | 118 | \ ======================================================================== 119 | -------------------------------------------------------------------------------- /src/examples/defers.f: -------------------------------------------------------------------------------- 1 | 2 | defer foo ' noop is foo 3 | 4 | : one defers foo ." one " ; 5 | : two defers foo ." two " ; 6 | : three defers foo ." three " ; 7 | : four defers foo ." four " ; 8 | 9 | foo 10 | 11 | -------------------------------------------------------------------------------- /src/examples/mmtest.f: -------------------------------------------------------------------------------- 1 | \ mmtest.f - x4 memory manager smoke test 2 | \ ------------------------------------------------------------------------ 3 | 4 | vocabulary mm mm definitions 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | \ this code allocates 20 thousand buffers of random size from 16 bytes to 9 | \ 16k bytes. to make sure the operating system actually gives us the 10 | \ allocated pages each allocated buffer is erased. when all buffers 11 | \ have been allocated they are freed in a random order. 12 | 13 | \ during allocation and deallocation various information is displayed. 14 | \ the top number is the total number of buffers thus far allocated. 15 | \ we then break down each heap. we show the size of the largest block, 16 | \ the total free memory, the total memory allocted and the number of 17 | \ buffers allocated within the heap. 18 | 19 | \ you will see your swap useage go up dramatically as blocks are allocated 20 | \ and then back down as they are freed. 21 | 22 | \ this code might run into ulimit for some users and might not function 23 | \ in a sane manner - ill add a call to sys-getrlimit to memoryl.f 24 | \ eventually 25 | 26 | \ ------------------------------------------------------------------------ 27 | 28 | 20000 var ### \ number of buffers to allocate 29 | 30 | \ ------------------------------------------------------------------------ 31 | \ array of allocated buffer addresses 32 | 33 | create buffers ### cells allot 34 | buffers ### cells erase 35 | 36 | \ ------------------------------------------------------------------------ 37 | 38 | 0 var a-failed \ number of failed allocations 39 | 0 var f-failed \ number of failed de-allocations 40 | 41 | defer function \ function to execute (alloc, free, randomize) 42 | 43 | \ ------------------------------------------------------------------------ 44 | 45 | : .count ( n1 --- ) 4 0 at 10 .r ; 46 | 47 | \ ------------------------------------------------------------------------ 48 | \ display information about all allocated buffers 49 | 50 | : .info ( --- ) 51 | 5 0 at .mem-info el cr 52 | 3 spaces a-failed . ." Failed Allocations" cr 53 | 3 spaces f-failed . ." Failed Frees" cr 54 | el ; 55 | 56 | \ ------------------------------------------------------------------------ 57 | \ (.") type word to help display info during burnin 58 | 59 | : (.foo") 60 | 2 0 at 61 | r> count 2dup + >r type 62 | ### . ." buffers... " ; 63 | 64 | \ ------------------------------------------------------------------------ 65 | 66 | : .foo" ( --- ) 67 | compile (.foo") ," ; immediate 68 | 69 | \ ------------------------------------------------------------------------ 70 | \ allocate random buffer of size 16 bytes to 16k bytes 71 | 72 | : (ab) ( i --- ) 73 | dup>r 1+ .count 74 | 16384 rnd dup allocate 75 | if 76 | dup buffers r> cells + ! 77 | swap 15 + -16 and erase 78 | else 79 | incr> a-failed 80 | r> 2drop 81 | then ; 82 | 83 | \ ------------------------------------------------------------------------ 84 | \ free one buffer 85 | 86 | : (fb) ( i --- ) 87 | ### swap - dup .count 88 | dup rnd 89 | dup cells buffers + @ free 90 | if 91 | dup rot swap - swap 92 | cells buffers + 93 | dup cell+ swap rot cells 94 | cmove 95 | ### 1- cells buffers + off 96 | else 97 | 2drop incr> f-failed 98 | then ; 99 | 100 | \ ------------------------------------------------------------------------ 101 | \ repeatedly execute selected function 102 | 103 | : df ( 'function --- ) 104 | is function ### 0 105 | do 106 | i function .info 107 | key? if key drop quit then 108 | loop ; 109 | 110 | \ ------------------------------------------------------------------------ 111 | 112 | : aa .foo" Allocating " ['] (ab) df ; 113 | : dd .foo" Freeing " ['] (fb) df ; 114 | 115 | \ ------------------------------------------------------------------------ 116 | 117 | : main 118 | clear curoff 119 | timer-reset 120 | aa dd cr cr 121 | .elapsed cr 122 | curon ; 123 | 124 | \ ------------------------------------------------------------------------ 125 | 126 | \ burn 127 | 128 | \ ======================================================================== 129 | -------------------------------------------------------------------------------- /src/examples/mmtest/display.f: -------------------------------------------------------------------------------- 1 | \ display.f - display update for memory manager smoke test 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading display.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | : wspace bl w wemit ; 9 | 10 | \ ------------------------------------------------------------------------ 11 | \ erase info from bottom line of display. leave | chars intact 12 | 13 | : .erase 14 | tframe count bounds \ for each char of the tframe string di 15 | do 16 | i c@ bl = \ fetch it, if it is a bl emit a bl to 17 | ?: \ the window, else cursor forward over | 18 | wspace 19 | wcuf 20 | loop ; 21 | 22 | \ ------------------------------------------------------------------------ 23 | \ display number in current column of info display right aligned 24 | 25 | : w. ( n1 n2 --- ) 26 | >r \ save alignment width 27 | 0 <# #s #> \ convert number to string in current base 28 | dup r@ < \ is string shorter than alignment width? 29 | if 30 | r@ over - rep wspace \ if so pad out the number display 31 | then 32 | w -rot wtype r>drop \ display the number right aligned 33 | wcuf wcuf ; \ cursor over | and one space 34 | 35 | \ ------------------------------------------------------------------------ 36 | 37 | : x9 dcount 9 w. ; \ display number in column right aligned 38 | : x5 dcount 5 w. ; \ to nine or five digits (pad as required) 39 | 40 | \ ------------------------------------------------------------------------ 41 | \ display info for one heap (already collected) 42 | 43 | : w.info ( --- ) 44 | #heaps 1- heap# - 4 w. \ display heap number in column 1 45 | info \ point to heap info array 46 | x9 x9 x9 x5 x5 x5 x5 \ display 7 items of info for heap 47 | drop ; 48 | 49 | \ ------------------------------------------------------------------------ 50 | \ display info for heap 51 | 52 | : .heap 53 | heap# 2 + 1 w win-at \ position cursor within window for heap 54 | dup get-info \ collect info about heap to be displayed 55 | w.info \ dusplay it 56 | incr> heap# ; \ bump heap number 57 | 58 | \ ------------------------------------------------------------------------ 59 | \ display info for all heaps 60 | 61 | : .heaps 62 | w win>bold 63 | heaps head@ \ fetch head of heap list 64 | begin 65 | ?dup \ while we still have heaps do... 66 | while 67 | .heap next@ \ display info about heap, get next heap 68 | repeat ; 69 | 70 | \ ------------------------------------------------------------------------ 71 | \ update display of heap info 72 | 73 | : .update 74 | ?#heaps off> heap# \ get total # of heaps, reset current heap # 75 | .heaps \ display all heaps 76 | 77 | \ while deallocating, any heap that no longer has any allocated buffers 78 | \ is returned to the BIOS (Linux :) and the info that was displayed on 79 | \ the bottom of the .heaps is now invalid.. write one blank line to 80 | \ the bottom unless we have a full page 81 | 82 | heap# 9 < 83 | if 84 | heap# 2 + 0 w win-at 85 | .erase 86 | then 87 | 88 | s .screen ; \ push updated windows to the screen 89 | 90 | \ ======================================================================== 91 | -------------------------------------------------------------------------------- /src/examples/mmtest/init.f: -------------------------------------------------------------------------------- 1 | \ init.f - tui initialization for memory manager smoke test 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading init.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | screen: s \ all windows require a parent screen 9 | 10 | window: backdrop \ checkerboard backdrop window 11 | window: w \ main window 12 | window: inf \ about window 13 | 14 | \ ------------------------------------------------------------------------ 15 | 16 | create tframe 17 | ," x x x x x x x " 18 | 19 | create tags 20 | ," Heap Largest Free Used DF DA DC DT " 21 | 22 | create spacer 23 | ," qqqqqqnqqqqqqqqqqnqqqqqqqqqqnqqqqqqqqqqnqqqqqqnqqqqqqnqqqqqqnqqqqqq" 24 | 25 | \ ------------------------------------------------------------------------ 26 | 27 | : wcuf w win-cuf ; 28 | 29 | \ ------------------------------------------------------------------------ 30 | 31 | : .tags 32 | w winbold 33 | blue w win>fg 34 | tags count bounds 35 | do 36 | i c@ dup bl = 37 | if 38 | drop wcuf 39 | else 40 | w wemit 41 | then 42 | loop 43 | w win>alt w winalt w winfg 50 | 0 0 w win-at w tframe count wtype 51 | 0 0 w win-at .tags 52 | cyan w win>fg 53 | 1 0 w win-at w spacer count wtype 54 | 55 | 9 0 56 | do 57 | i 2 + 0 w win-at w tframe count wtype 58 | loop ; 59 | 60 | \ ------------------------------------------------------------------------ 61 | \ initialize backdrop widnow 62 | 63 | : init-backdrop 64 | backdrop >r \ working with this window for a bit 65 | cols 2- rows 3 - \ set window dimensions and allocate buffers 66 | r@ (window:) drop 67 | black r@ win-color! \ black bg, black fg (trust me :) 68 | blue black >color \ set attribs for borders too 69 | r@ win-bcolor! 70 | r@ win>bold \ set bold on for window 71 | r@ >fill \ set backfill flag on for window (checkers) 72 | r@ >borders \ give window borders 73 | r@ win-clr \ clear the window 74 | 1 1 r> winpos! ; \ this is really 0, 0 :) 75 | 76 | \ ------------------------------------------------------------------------ 77 | \ initialize main info window 78 | 79 | : init-w 80 | w >r \ main widnow... 81 | 67 11 \ set window size, allocate buffers 82 | r@ (window:) drop 83 | white blue >color \ set attribs 84 | r@ win-color! 85 | cyan black >color \ set window border attribs too 86 | r@ win-bcolor! 87 | 88 | r@ >borders \ give window borders 89 | r@ win-clr \ clear the window 90 | r@ >locked 91 | 92 | .frame \ draw columns 93 | 94 | 4 3 r> winpos! ; \ locate the window 95 | 96 | \ ------------------------------------------------------------------------ 97 | 98 | : init-inf 99 | inf >r 100 | 45 6 r@ (window:) drop 101 | cyan black >color 102 | r@ win-color! 103 | green black >color 104 | r@ win-bcolor! 105 | r@ >borders 106 | r@ win-clr 107 | 10 19 r@ winpos! 108 | 109 | 0 1 r@ win-at r@ win" x4 memory manager smoke test" 110 | 2 1 r@ win-at r@ win" Allocating 20000 buffers of random size" 111 | 3 1 r@ win-at r@ win" and freeing them in a random order!" 112 | 4 1 r@ win-at r> win" Press any key to abort" ; 113 | 114 | \ ------------------------------------------------------------------------ 115 | 116 | : init-tui 117 | clear curoff \ clear display, turn cursor off 118 | cols rows \ allocate buffers for screen 119 | s (screen:) drop 120 | init-backdrop init-w \ initialize windows 121 | init-inf 122 | s backdrop win-attach \ attach windows to screen 123 | s inf win-attach 124 | s w win-attach ; \ with main window on top 125 | 126 | \ ------------------------------------------------------------------------ 127 | 128 | : deinit-tui 129 | backdrop close-win 130 | w close-win 131 | inf close-win 132 | s close-screen ; 133 | 134 | \ ======================================================================== 135 | -------------------------------------------------------------------------------- /src/examples/mmtest/mmtest.f: -------------------------------------------------------------------------------- 1 | \ mmtest.f - load file for memory manager smoke test 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading mmtest.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | fload src/examples/mmtest/vars.f \ variables for smoke test 9 | fload src/examples/mmtest/init.f \ tui initialization 10 | fload src/examples/mmtest/display.f \ display update 11 | fload src/examples/mmtest/run.f \ main 12 | 13 | \ ======================================================================== 14 | -------------------------------------------------------------------------------- /src/examples/mmtest/run.f: -------------------------------------------------------------------------------- 1 | \ run.f - main for memory manager smoke test 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading run.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | : [] cells + ; 9 | 10 | \ ------------------------------------------------------------------------ 11 | 12 | : aok ( a1 --- ) 13 | buffers #b []! \ save address of new allocation 14 | incr> #b ; \ count successfull allocation 15 | 16 | \ ------------------------------------------------------------------------ 17 | 18 | : afail 19 | incr> a-fail ; \ count failure 20 | 21 | \ ------------------------------------------------------------------------ 22 | \ allocate a random sized block 16 bytes to 16k 23 | 24 | : (a) ( --- ) 25 | 16384 rnd \ get random size 26 | 15 + -16 and \ make sure size is multiple of 16 27 | allocate 28 | ?: aok afail ; 29 | 30 | \ ------------------------------------------------------------------------ 31 | 32 | : (f) 33 | decr> #b 34 | buffers #b []@ 35 | free ?exit 36 | incr> f-fail ; 37 | 38 | \ ------------------------------------------------------------------------ 39 | 40 | : (shuffle) ( ix --- ix` ) 41 | >r 42 | begin 43 | #b 1- rnd 44 | dup r@ = 45 | while 46 | drop 47 | repeat 48 | buffers swap [] 49 | buffers r@ [] 50 | juggle r> 1+ ; 51 | 52 | \ ------------------------------------------------------------------------ 53 | 54 | : shuffle 55 | 0 3 rep (shuffle) drop ; 56 | 57 | \ ------------------------------------------------------------------------ 58 | \ do one itteration of selected function (allocate) or (deallocate) 59 | 60 | : ((run)) ( --- ) 61 | func .update 62 | key? \ do function, update display, check for key 63 | if \ if key hit... break out 64 | key drop quit 65 | then ; 66 | 67 | \ ------------------------------------------------------------------------ 68 | \ run ### itterations of selected function 69 | 70 | : (run) ( cfa --- ) 71 | is func 72 | ### rep ((run)) ; 73 | 74 | \ ------------------------------------------------------------------------ 75 | \ select (allocate), run it, select (deallocate), run it 76 | 77 | : run 78 | ['] (a) (run) 79 | ### rep shuffle 80 | ['] (f) (run) ; 81 | 82 | \ ------------------------------------------------------------------------ 83 | 84 | : main 85 | ### cells allocate 0= 86 | abort" Out of Memory?" 87 | !> buffers 88 | init-tui 89 | blue w win>fg 90 | w win>bold 91 | true setalloc 92 | 3 rep run 93 | buffers free drop 94 | cr cr cr cr cr cr cr cr cr cr cr 95 | deinit-tui ; 96 | 97 | \ ======================================================================== 98 | -------------------------------------------------------------------------------- /src/examples/mmtest/vars.f: -------------------------------------------------------------------------------- 1 | \ mmtest.f - memory manager smoke test 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading vars.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | defer func \ allocation or deallocation 9 | 10 | create info 7 cells allot \ info about a heap we are about to display 11 | 12 | 20000 const ### \ number of buffers to allocate 13 | 14 | 0 var column \ current column we are displayuing info to 15 | 0 var row \ current row (index) 16 | 0 var heap# \ current heap number being displayed 17 | 0 var #heaps \ number of heaps 18 | 0 var buffers \ array of buffers allocated for test 19 | 0 var #b \ count of successfull buffer allocations 20 | 0 var a-fail \ number of failed allocations 21 | 0 var f-fail \ number of failed deallocations 22 | 23 | \ ------------------------------------------------------------------------ 24 | 25 | : ?#heaps 26 | off> #heaps 27 | heaps 28 | begin 29 | ?dup 30 | while 31 | incr> #heaps 32 | next@ 33 | repeat ; 34 | 35 | \ ------------------------------------------------------------------------ 36 | \ get info about a healp we want to display 37 | 38 | : get-info 39 | ?mem-info \ returns 7 items on the stack 40 | 7 for \ stuff them in the info array 41 | info r@ []! 42 | nxt ; 43 | 44 | \ ======================================================================== 45 | -------------------------------------------------------------------------------- /src/examples/revbits.f: -------------------------------------------------------------------------------- 1 | \ snagged from the c function to do the same thing 2 | \ ------------------------------------------------------------------------ 3 | 4 | \ ------------------------------------------------------------------------ 5 | \ reverses all the bits of 32 bit value n1 6 | 7 | \ : revbits ( n1 --- n2 ) 8 | \ dup 1 u>> $55555555 and swap 1 << $aaaaaaaa and or 9 | \ dup 2 u>> $33333333 and swap 2 << $cccccccc and or 10 | \ dup 4 u>> $0f0f0f0f and swap 4 << $f0f0f0f0 and or 11 | \ dup 8 u>> $00ff00ff and swap 8 << $ff00ff00 and or 12 | \ dup 16 u>> $0000ffff and swap 16 << $ffff0000 and or ; 13 | 14 | \ the above is 313 bytes in x4 15 | 16 | \ ------------------------------------------------------------------------ 17 | \ this is maybe more obfuscated 18 | 19 | \ here 20 | \ $0000ffff , $ffff0000 , $00ff00ff , $ff00ff00 , 21 | \ $0f0f0f0f , $f0f0f0f0 , $33333333 , $cccccccc , 22 | \ $55555555 , $aaaaaaaa , 23 | 24 | \ ------------------------------------------------------------------------ 25 | 26 | \ : revbits 27 | \ 1 5 28 | \ for 29 | \ 2dup << >r tuck u>> r> 30 | \ r@ 3 << [ swap literal ] + 31 | \ dup @ swap 4+ @ 32 | \ rot and -rot and or 33 | \ swap 2* 34 | \ nxt 35 | \ drop ; 36 | 37 | \ the above is 189 bytes 38 | 39 | \ ------------------------------------------------------------------------ 40 | \ this is definatly more obfuscated :P 41 | 42 | here 43 | $00ff w, $ff00 w, $0f0f w, $f0f0 w, 44 | $3333 w, $cccc w, $5555 w, $aaaa w, 45 | 46 | \ ------------------------------------------------------------------------ 47 | \ bit reverses w2 exits with w1 on top 48 | 49 | here ] ( w1 w2 --- w2' w1 ) 50 | $40001 split 51 | for 52 | 2dup u>> >r tuck << r> 53 | r@ cells [ rot ]# + @ split 54 | -rot and -rot and or 55 | swap 2* 56 | nxt 57 | drop swap ; 58 | 59 | \ ------------------------------------------------------------------------ 60 | \ joins the two bit reversed words 61 | 62 | here 63 | ] join ; 64 | 65 | \ ------------------------------------------------------------------------ 66 | \ bit reverses 32 bit n1 67 | 68 | : revbits ( n1 --- n1' ) 69 | split \ split tp w1 and w2 70 | literal >r \ set address to rejoin 71 | literal dup 2>r ; \ set address to bit reverse w1 and w2 72 | 73 | \ the above is 189 bytes too :) 74 | 75 | \ ------------------------------------------------------------------------ 76 | \ this is alot smaller but not obfuscated :) 77 | 78 | \ : revbits ( n1 --- 0 79 | \ 0 32 80 | \ for 81 | \ 2* 82 | \ over 1 and + 83 | \ swap 2/ swap 84 | \ nxt nip ; 85 | 86 | \ ======================================================================== 87 | -------------------------------------------------------------------------------- /src/examples/showargs.f: -------------------------------------------------------------------------------- 1 | \ ------------------------------------------------------------------------ 2 | \ 3 | \ this file is a simple example of using command line arguments. 4 | \ 5 | \ invoke with something like 6 | \ ./x4 -f showargs.f arugment_1 filename.ext --showopts moretext 7 | \ then type 'showargs'. We should see 4 arguments printed out, one per 8 | \ line. 9 | \ 10 | \ see args.f in the src/ext directory for more details 11 | \ 12 | \ ------------------------------------------------------------------------ 13 | \ print an ASCIIZ string 14 | 15 | : ztype ( a1 -- ) 16 | begin 17 | dup \ save a1 18 | c@ \ get char 19 | ?dup \ zero? 20 | while \ no, so lets... 21 | emit \ ... output it 22 | 1+ \ next string address 23 | repeat \ repeat until we hit 0 24 | drop ; \ user doesn't need a pointer to 0 25 | 26 | \ ------------------------------------------------------------------------ 27 | \ print out the command line argument list 28 | \ argc is the total number of arguments on the command line 29 | \ arg# is the number of system arguments 30 | \ arg@ consumes arguments, so running it a second time gives an error 31 | 32 | : showargs ( -- ) 33 | cr \ newline to be pretty 34 | 35 | argc arg# > not if \ see if any user arguments left 36 | abort" No arguments!" \ bzzzzt! None there. 37 | then 38 | 39 | argc arg# - 0 do \ get number of user arguments 40 | arg@ ztype cr \ get next argument, print it, newline 41 | loop ; \ repeat for all arguments 42 | 43 | \ ======================================================================== 44 | -------------------------------------------------------------------------------- /src/examples/sigtst.f: -------------------------------------------------------------------------------- 1 | 2 | defer realarm 3 | 4 | 1 27 syscall 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ the actual signal handler function 8 | 9 | : (alarm) 10 | realarm \ re init alarm signal 11 | 99 >message ; \ throw message 99 to all catchers thereof 12 | 13 | \ ------------------------------------------------------------------------ 14 | \ lets create a signal handler that does the above 15 | 16 | ' (alarm) 14 signal alarm drop 17 | 18 | \ ------------------------------------------------------------------------ 19 | 20 | : (realarm) 21 | ['] alarm 14 22 | drop ; 23 | 24 | ' (realarm) is realarm 25 | 26 | \ ------------------------------------------------------------------------ 27 | 28 | 0 var got-alarm 29 | 30 | : my-alarm 31 | on> got-alarm 32 | ." alarm signal received" cr ; 33 | 34 | \ ------------------------------------------------------------------------ 35 | 36 | : test 37 | 99 ['] my-alarm +message 38 | begin 39 | 5 \ start a 5 second alarm clock 40 | begin 41 | ." no alarm" cr 42 | 1 seconds 43 | got-alarm 44 | until 45 | off> got-alarm key? 46 | until 47 | 99 ['] my-alarm -message 48 | key drop ; 49 | 50 | \ ======================================================================== 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /src/examples/test.f: -------------------------------------------------------------------------------- 1 | #! ./x4 -s 2 | \ ------------------------------------------------------------------------ 3 | 4 | \ this file shows how x4 can be used to interpret scripts pased to it 5 | \ via a shebang. 6 | \ 7 | \ x4 will see a command line of '-s /path/to/script.f' because 8 | \ the shebanged file is passed to us as an extra parameter. 9 | 10 | \ ------------------------------------------------------------------------ 11 | 12 | : %tt ( n1 n2 --- n1 n2' ) 13 | over + dup 4 u.r ; 14 | 15 | \ ------------------------------------------------------------------------ 16 | \ the word tt will display a complete times table 17 | 18 | : (tt) ( n1 --- ) 19 | 0 12 rep %tt 20 | cr 2drop ; 21 | 22 | \ ------------------------------------------------------------------------ 23 | 24 | : tt 25 | cr cr 13 1 26 | do 27 | i (tt) 28 | loop 29 | cr ; 30 | 31 | \ ------------------------------------------------------------------------ 32 | \ x4 automatically quits without saying bye when a script finishes 33 | 34 | tt \ after loading - run times table display 35 | 36 | \ ======================================================================== 37 | -------------------------------------------------------------------------------- /src/ext/args.f: -------------------------------------------------------------------------------- 1 | \ args.f - x4 command line args primatives 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading args.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ user must initialize these in application code 8 | 9 | 0 var arg# \ number of next arg to process 10 | 0 var arglist \ list of known args (list of counted strings) 11 | 0 var argscount \ number of args in above list 12 | 13 | \ ------------------------------------------------------------------------ 14 | \ get next arg from argp[] array 15 | 16 | 25 | 26 | : arg@ ( --- a1 ) 27 | (arg@) incr> arg# ; \ does increment arg# (number of arg parsed) 28 | 29 | \ ------------------------------------------------------------------------ 30 | 31 | : (?arg) ( arg# *arg list --- arg# | ) 32 | begin 33 | count 2dup + >r \ get a1/n1 of arg option (save addr of next) 34 | pluck swap comp 0= \ is argp[arg#] same as arglist[n] ? 35 | if 36 | 2r> 3drop 1+ \ yes - return n 37 | incr> arg# exit 38 | then 39 | swap 1+ swap r> \ increment n retrieve next arg list entry 40 | pluck argscount = \ is n maxed ? 41 | until ; 42 | 43 | \ ------------------------------------------------------------------------ 44 | 45 | \ the following does not increment arg# unless it finds an arg it 46 | \ recognizes from the supplied list. this gives you the ability to 47 | \ further process an unrecognized arg 48 | 49 | : ?arg ( --- n1 true | false ) 50 | 0 (arg@) arglist 51 | (?arg) \ returns to caller if match found 52 | 3drop false ; \ returns to here if no match (error) 53 | 54 | \ ------------------------------------------------------------------------ 55 | \ arg list creation words 56 | 57 | headers> 58 | 59 | : args: ( --- a1 0 ) 60 | create here 0 \ create named args list compile 0 args count 61 | cell allot \ count will be patched when list is complete 62 | does> 63 | dcount \ fetch args count 64 | !> argscount 65 | !> arglist 66 | off> arg# ; 67 | 68 | \ ------------------------------------------------------------------------ 69 | \ add an arg to the list 70 | 71 | : arg" ( n1 --- n2 ) 72 | 1+ \ bunp args count 73 | [compile] ," ; \ compile arg string 74 | 75 | \ ------------------------------------------------------------------------ 76 | \ complete args list 77 | 78 | : ;args ( a1 n1 --- ) 79 | swap ! ; 80 | 81 | \ ------------------------------------------------------------------------ 82 | \ application code must initialize for and process args as follows 83 | 84 | \ args: my-args 85 | \ arg" -1" 86 | \ arg" -f" 87 | \ arg" -h" 88 | \ ;args 89 | \ 90 | \ : do-my-args 91 | \ my-args \ tell this extension what list were using 92 | \ begin 93 | \ ?arg \ get argslist index of next arg 94 | \ case: 95 | \ 0 opt .useage \ not in list 96 | \ 1 opt do-dash-one 97 | \ 2 opt do-dash-f 98 | \ 3 opt do-dot-help 99 | \ ;case 100 | \ arg# argscount = 101 | \ until ; 102 | 103 | \ if ?arg returns failure your code could call arg@ and further process 104 | \ the offending arg. if an arg expects an option string it is up to you 105 | \ to handle it. e.g. the -f above might want a filename to follow it in 106 | \ the argp[] list. you would call arg@ to get the file name. 107 | 108 | \ ------------------------------------------------------------------------ 109 | 110 | behead 111 | 112 | \ ======================================================================== 113 | -------------------------------------------------------------------------------- /src/ext/case.f: -------------------------------------------------------------------------------- 1 | \ case.f - x4 case compilation and execution 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading case.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | compiler definitions 9 | 10 | \ ------------------------------------------------------------------------ 11 | 12 | 25 | 26 | : dflt ( --- ) 27 | ' !> [dflt] ; \ compiled in later by ;case 28 | 29 | \ ------------------------------------------------------------------------ 30 | \ initiate a case statement 31 | 32 | : case: ( --- 0 ) 33 | compile docase \ compile run time handler for case statement 34 | off> [dflt] \ assume no default vector 35 | off> #case \ number of cases is 0 so far 36 | >mark \ case exit point compiled to here 37 | >mark \ default vector filled in by ;case (maybe) 38 | >mark \ number of cases compiled to here 39 | [compile] [ ; immediate 40 | 41 | \ ------------------------------------------------------------------------ 42 | 43 | : opt ( opt --- ) 44 | , \ compile opt 45 | ' , \ get vector and compile it too 46 | incr> #case ; \ count number of cases in statement 47 | 48 | \ ------------------------------------------------------------------------ 49 | \ i resisted the urge to call this word esac :p (phew!!!) 50 | 51 | : ;case ( a1 a2 a3 --- ) 52 | #case swap ! 53 | [dflt] swap ! 54 | >resolve \ store case end point in case body 55 | ] ; 56 | 57 | \ ------------------------------------------------------------------------ 58 | 59 | forth definitions behead 60 | 61 | \ ======================================================================== 62 | -------------------------------------------------------------------------------- /src/ext/datetime/date.f: -------------------------------------------------------------------------------- 1 | \ date.f - x4 date display functions 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading date.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ 4 years worth of days per month 8 | 9 | 29 | 30 | create time$ ," 00:00:00" 31 | create day$ ," ---" 32 | 33 | \ ------------------------------------------------------------------------ 34 | 35 | 0 var year \ current year 36 | 0 var month \ current month 37 | 0 var day \ current day of the month 38 | 39 | \ ------------------------------------------------------------------------ 40 | \ construct time string 41 | 42 | : time>$ ( #seconds-since-epoc --- #days-since-epoc ) 43 | time$ count + hld ! \ compile time $ 44 | (t) (t) \ extract seconds and minutes 45 | 24 mswap 46 | # # 2drop ; \ kludge because #> assumes hld points to pad 47 | 48 | \ ------------------------------------------------------------------------ 49 | 50 | year \ current year is epoch plus.... 54 | 12 \ index into 48 month dpm table 55 | begin 56 | dup dpm + c@ \ get number of days in current month 57 | pluck u> not \ while # days since epoc is more than this 58 | while 59 | dup dpm + c@ \ subtract number of days in current month 60 | rot swap - \ from the number of days since the epoc 61 | swap 1+ \ increment month index into dpm table 62 | dup 47 > \ reached end of 4 years worth ? 63 | if 64 | drop 0 \ yes - reset to start of table 65 | 4 +!> year \ add 4 to year 66 | then 67 | repeat 68 | 12 /mod 1- \ might be on year 1 2 or 3 here so extract 69 | +!> year ; \ year and add (leaves month) 70 | 71 | \ the epoc started at the beinning of the year 1970 which is 3 years from 72 | \ a leap year so we had to index into the days per month table on the 73 | \ second year. when we see our first leap year we will add 4 years to the 74 | \ total years which is incorrect - the last thing we do above is decrement 75 | \ the year to fix this 76 | 77 | headers> 78 | 79 | \ ------------------------------------------------------------------------ 80 | \ it only took me 2 days to figure out how to get all this crap 81 | 82 | : (date@) ( seconds-since-epoc --- ) 83 | time>$ \ construct time string 84 | 85 | \ we now have the number of days since the epoch at top of stack 86 | 87 | dup 88 | 7 /mod drop 3 - \ extract day of the week 89 | dup 0< 7 and + 90 | 3 * days + 91 | day$ 1+ 3 cmove \ make day$ reflect current day of the week 92 | 93 | (year) 94 | 95 | !> month \ set current month 96 | 1+ !> day ; \ make day not zero based :) 97 | 98 | \ ------------------------------------------------------------------------ 99 | 100 | : date@ ( --- ) 101 | localtime (date@) ; 102 | 103 | \ ------------------------------------------------------------------------ 104 | \ display current date in rfc 2822 format 105 | 106 | : (.date) 107 | base decimal \ keep current base but make sure were in dec 108 | 109 | day$ count type \ display day of the week followed by a comma 110 | ',' emit space 111 | 112 | day 0 <# # # #> \ display current day of the month as 2 digits 113 | type space 114 | 115 | month 3 * months + \ display current month 116 | 3 type space 117 | 118 | year . \ display year 119 | 120 | time$ count type space \ display time 121 | 122 | toffset dup abs 36 / \ display current offset from gmt 123 | 0 <# # # # # rot 124 | 0< if '-' else '+' then \ show if were + or - from gmt 125 | hold #> type 126 | radix ; \ restore base 127 | 128 | \ ------------------------------------------------------------------------ 129 | 130 | : .date date@ (.date) ; \ fetch/calculate current date and time 131 | 132 | \ ======================================================================== 133 | -------------------------------------------------------------------------------- /src/ext/datetime/localtime.f: -------------------------------------------------------------------------------- 1 | \ localtime.f - x4 code to calculate local time 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading localtime.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | create tzname ," /etc/localtime" 9 | 10 | \ ------------------------------------------------------------------------ 11 | 12 | leapcount 43 | tzfile $20 + x@ !> timecnt 44 | tzfile $24 + x@ !> typecnt 45 | tzfile $28 + x@ !> charcnt 46 | 47 | tzfile $2c + dup !> ttime \ transition times 48 | ttime timecnt cells + !> ttype \ transition types 49 | ttype timecnt + !> ttinfo ; 50 | 51 | \ ------------------------------------------------------------------------ 52 | 53 | 1 13 syscall