├── extend ├── .gitignore ├── Makefile ├── src ├── examples │ ├── defers.f │ ├── bench │ │ ├── kcbench.f │ │ ├── bench.f │ │ ├── primes.f │ │ ├── litcon.f │ │ ├── benchie.f │ │ ├── nest.f │ │ ├── bits.f │ │ └── fib.f │ ├── mmtest │ │ ├── mmtest.f │ │ ├── vars.f │ │ ├── run.f │ │ ├── display.f │ │ └── init.f │ ├── test.f │ ├── sigtst.f │ ├── showargs.f │ ├── bot │ │ ├── irc.f │ │ ├── numeric.f │ │ └── bot.f │ ├── revbits.f │ ├── case.f │ └── mmtest.f ├── kernel │ ├── ldscript │ ├── Makefile │ ├── comment.s │ ├── parse.s │ ├── expect.s │ ├── rehash.s │ ├── reloc.s │ ├── comma.s │ ├── double.s │ ├── vocabs.s │ ├── header.s │ ├── interpret.s │ └── find.s └── ext │ ├── utf8.f │ ├── utils │ ├── getuid.f │ ├── stat.f │ ├── seaio │ │ └── test.f │ └── ioctl.f │ ├── env.f │ ├── init.f │ ├── debug │ ├── stackdisp.f │ ├── keys.f │ ├── window.f │ ├── info.f │ ├── utils.f │ └── debug.f │ ├── terminal │ └── twinch.f │ ├── struct.f │ ├── tty.f │ ├── message.f │ ├── vocabs.f │ ├── tui │ ├── screen.f │ ├── window.f │ └── border.f │ ├── case.f │ ├── rnd.f │ ├── ls.f │ ├── file.f │ ├── status.f │ ├── memman │ ├── dealloc.f │ ├── info.f │ └── heap.f │ ├── words.f │ ├── datetime │ ├── timer.f │ ├── localtime.f │ └── date.f │ ├── macros │ └── inline.f │ ├── args.f │ ├── variable.f │ ├── sockets.f │ ├── see │ ├── utils.f │ └── disp.f │ ├── number.f │ ├── hello.f │ └── dents.f ├── x4.rcf ├── LICENSE └── README ├── ADDENDUM └── quotes /extend: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | mv -f x4 x4_old 3 | printf "fload src/x4.f\n" | ./kernel.com 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.sublime* 2 | kernel.com 3 | src/kernel.o 4 | x4 5 | x4_old 6 | *.lst 7 | *~ 8 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/kernel/ldscript: -------------------------------------------------------------------------------- 1 | 2 | ENTRY(origin) 3 | 4 | SECTIONS 5 | { 6 | .text : { *(.text) *(list) *(headers) } 7 | .bss : ALIGN(1) 8 | { 9 | *(.bss) 10 | . = . + 0x100000 - (SIZEOF(.text) + SIZEOF(.data)); 11 | } 12 | } 13 | 14 | 15 | -------------------------------------------------------------------------------- /src/ext/utf8.f: -------------------------------------------------------------------------------- 1 | \ utf8 table dump. 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading utf8.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | : .utf8 ( from --- ) 9 | hex 10 | 256 bounds 11 | do 12 | i 16 mod 0= 13 | if 14 | cr cr 15 | i 0 <# # # # # # # # # #> type space 16 | then 17 | i (utf8) space 18 | loop ; 19 | 20 | \ ======================================================================== 21 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /x4.rcf: -------------------------------------------------------------------------------- 1 | \ x4.rcf - x4 custom initiliazation 2 | \ ------------------------------------------------------------------------ 3 | 4 | \ copy this file to your home direcory and rename it to .x4.rcf 5 | \ and it will be automaticlaly loaded by x4 after all default 6 | \ initialization chains have been run (just prior to jumping to quit). 7 | 8 | \ ------------------------------------------------------------------------ 9 | \ if command history (cursor up down) does not work enable the following 10 | 11 | \ smkx \ enable cursor keys in terminal 12 | 13 | \ ======================================================================== 14 | -------------------------------------------------------------------------------- /src/ext/utils/getuid.f: -------------------------------------------------------------------------------- 1 | \ getuid.f - get user id of current process 2 | \ ------------------------------------------------------------------------ 3 | 4 | 9 | 0 49 syscall 10 | 11 | \ ------------------------------------------------------------------------ 12 | 13 | headers> 14 | 15 | : getuid ( --- uid | -1 ) 16 | 17 | dup -1 <> ?exit 18 | drop ; 19 | 20 | \ ------------------------------------------------------------------------ 21 | 22 | behead 23 | 24 | \ ======================================================================== 25 | -------------------------------------------------------------------------------- /src/ext/env.f: -------------------------------------------------------------------------------- 1 | \ env.f - search environment for supplied string 2 | \ ------------------------------------------------------------------------ 3 | 4 | \ a1 = string to search for 5 | \ a2 = env var to compare against 6 | 7 | : envcmp ( a1 a2 --- a2 n1 t | f ) 8 | 2dup swap count comp 0= 9 | if 10 | strlen '=' scan 11 | 1 /string 12 | rot drop true 13 | else 14 | 2drop false 15 | then ; 16 | 17 | \ ------------------------------------------------------------------------ 18 | 19 | : getenv ( a1 --- a2 n1 t | f ) 20 | envp 21 | begin 22 | dup>r @ ?dup 23 | while 24 | >r dup r> envcmp 25 | if 26 | rot r> 2drop 27 | true exit 28 | then 29 | r> cell+ 30 | repeat 31 | r> 2drop false ; 32 | 33 | \ ======================================================================== 34 | -------------------------------------------------------------------------------- /src/kernel/Makefile: -------------------------------------------------------------------------------- 1 | ## ----------------------------------------------------------------------- 2 | ## Configuration 3 | 4 | # these should realy be set in the master make file 5 | 6 | list = -l../kernel.lst 7 | debug = -g 8 | 9 | ## ----------------------------------------------------------------------- 10 | ## Variables 11 | 12 | flags = $(debug) $(list) -felf32 13 | 14 | all: kernel 15 | 16 | # includes = \ 17 | # reloc.s syscalls.s stack.s memory.s \ 18 | # logic.s math.s loops.s exec.s io.s \ 19 | # find.s fload.s compile.s interpret.s \ 20 | #~\ vocabs.s 21 | 22 | kernel: kernel.o 23 | @ld -O2 -m elf_i386 ldscript -o../../kernel.com ../kernel.o 24 | @strip -R .comment ../../kernel.com 25 | 26 | #$(includes) 27 | kernel.o: x4.asm 28 | @nasm $(flags) x4.asm -o ../kernel.o 29 | 30 | ## ======================================================================= 31 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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/ext/init.f: -------------------------------------------------------------------------------- 1 | \ init.f - x4 custom initialization 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading init.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ this file should be in your home directory 8 | 9 | create rc-file 10 | ," ~/.x4.rcf" 11 | 12 | \ ------------------------------------------------------------------------ 13 | \ we need to get the user name out of the environment... 14 | 15 | create env-path ," HOME" 16 | 17 | \ ------------------------------------------------------------------------ 18 | 19 | : custom-init 20 | defers ldefault \ make sure everything else has initialized 21 | 22 | env-path getenv \ get username from environment 23 | 0= ?exit \ eh? 24 | 25 | hhere $! \ concat username into string 26 | rc-file count hhere $+ \ concat rc filename 27 | 28 | 0 dup hhere count \ verify file exists 29 | s>z 30 | 31 | 0> ?: exit \ close file or exit if file missing 32 | 33 | 0 dup hhere 1+ (fload) ; \ if it exists interpret it 34 | 35 | \ ======================================================================== 36 | -------------------------------------------------------------------------------- /src/ext/debug/stackdisp.f: -------------------------------------------------------------------------------- 1 | \ stackdisp.f 2 | \ ------------------------------------------------------------------------ 3 | 4 | 0 var sw \ which stack window we are updating 5 | 0 var s0 \ address of bottom of this stack 6 | 0 var s \ address of current top of this stack 7 | 8 | \ ------------------------------------------------------------------------ 9 | 10 | : .stack ( win s0 s --- ) 11 | !> s !> s0 !> sw 12 | sw win-clr \ erase stack window 13 | 14 | 7 0 sw win-at \ put cursor on bottom line of stack 15 | s0 0 cell/ 8 min 0 \ for a max of 8 stack items 16 | do 17 | sw win-cr \ scroll window up one line 18 | s i []@ \ get next item from stack 19 | 0 <# 8 rep # #> bounds \ for each char of number (string) 20 | do 21 | i c@ sw dup win-cx@ 22 | 7 = ?: (wemit) wemit \ display with cursor advance or no advance 23 | loop 24 | loop ; 25 | 26 | \ ------------------------------------------------------------------------ 27 | 28 | : .pstack ( --- ) pwin sp0 app-sp .stack ; 29 | : .rstack ( --- ) rwin app-rp0 app-rp .stack ; 30 | 31 | \ ======================================================================== 32 | -------------------------------------------------------------------------------- /src/ext/utils/stat.f: -------------------------------------------------------------------------------- 1 | \ stat.f - x4 stat and fstat 2 | \ ------------------------------------------------------------------------ 3 | 4 | \ ------------------------------------------------------------------------ 5 | 6 | struct: stat 7 | 2 dd st_dev \ device 8 | 1 dw st_ino \ inode 9 | 1 dd st_mode \ protection 10 | 1 dd st_nlink \ number of hard links 11 | 1 dd st_uid \ user ID of owner 12 | 1 dd st_gid \ group ID of owner 13 | 2 dd st_rdev \ device type (if inode device) 14 | 1 dd st_size \ total size, in bytes 15 | 1 dd st_blksize \ blocksize for filesystem I/O 16 | 1 dd st_blocks \ number of blocks allocated 17 | 1 dd st_atime \ time of last access 18 | 1 dd st_mtime \ time of last modification 19 | 1 dd st_ctime \ time of last change 20 | ;struct 21 | 22 | \ ------------------------------------------------------------------------ 23 | \ define some syscalls... 24 | 25 | 2 106 syscall 26 | 2 107 syscall 27 | 2 108 syscall 28 | 29 | \ ------------------------------------------------------------------------ 30 | 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/ext/terminal/twinch.f: -------------------------------------------------------------------------------- 1 | \ twinch.f - terminal winch signal handling (window change) 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( twinch.f ) forth cr terminal 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | winch \ terminal winch signal handler 11 | 12 | \ ------------------------------------------------------------------------ 13 | \ the following two definitions refer to each other !!! 14 | 15 | : winch ( --- ) \ signal handler for winch signal 16 | 0 >message \ send message 0 (notify of winch) 17 | >winch ; \ signals are oneshot. reload 18 | 19 | \ ------------------------------------------------------------------------ 20 | \ set handler for signal 28 which is a window change signal 21 | 22 | : (>winch) ( --- ) 23 | ['] winch 28 drop ; 24 | 25 | ' (>winch) is >winch 26 | 27 | \ ------------------------------------------------------------------------ 28 | 29 | : xyzzy ( --- ) 30 | defers default 31 | 0 ['] get-tsize +message \ add handler for message 0 32 | >winch ; \ initialize winch signal handler 33 | 34 | \ ======================================================================== 35 | -------------------------------------------------------------------------------- /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/ext/debug/keys.f: -------------------------------------------------------------------------------- 1 | \ keys.f - x4 debugger keyboard handling 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( keys.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ advance/retreat cursor in code window1 8 | 9 | : bug-down ( --- ) csr-ix #xu 1- = ?exit incr> csr-ix ; 10 | : bug-up ( --- ) csr-ix 0= ?exit decr> csr-ix ; 11 | 12 | \ ------------------------------------------------------------------------ 13 | \ these will peek (nest) into nestable definitions 14 | 15 | : bug-right ; \ peek into nestable xt 16 | : bug-left ; \ unpeek out of nestable xt 17 | : bug-home ; \ restore view to debut point 18 | : do-enter ; 19 | 20 | \ ------------------------------------------------------------------------ 21 | \ handle keys that return an escape sequence not a single character 22 | 23 | : bug-actions 24 | case: 25 | key-down opt bug-down 26 | key-home opt bug-home 27 | key-left opt bug-left 28 | key-right opt bug-right 29 | key-up opt bug-up 30 | key-ent opt do-enter 31 | ;case 32 | bug-see ; 33 | 34 | \ ------------------------------------------------------------------------ 35 | \ debugger main loop 36 | 37 | : bug-main ( a1 --- ) 38 | bug-see \ decompile word at top of see-stack 39 | begin 40 | key $1b = 41 | until ; 42 | 43 | \ ======================================================================== 44 | -------------------------------------------------------------------------------- /src/kernel/comment.s: -------------------------------------------------------------------------------- 1 | ; comment.s 2 | ; ------------------------------------------------------------------------ 3 | 4 | ; ------------------------------------------------------------------------ 5 | 6 | _immediate_ 7 | 8 | colon '\', backslash ; ' 9 | dd plit, 0xa 10 | dd parse, drop2 11 | dd exit 12 | 13 | ; ------------------------------------------------------------------------ 14 | ; stack comment - ignore everything in input stream till next ) 15 | 16 | _immediate_ 17 | 18 | colon '(', lparen 19 | dd plit, ')' 20 | dd parse, drop2 21 | dd exit 22 | 23 | ; ------------------------------------------------------------------------ 24 | ; ignore but echo evrything till next ) in input stream 25 | 26 | _immediate_ 27 | 28 | colon '.(', dotlparen 29 | dd plit, ')' 30 | dd parse, type 31 | dd exit 32 | 33 | ; ------------------------------------------------------------------------ 34 | ; ignore whole of rest of file 35 | 36 | _immediate_ 37 | 38 | colon '\s', backs 39 | dd floads 40 | dd qcolon, abort_fload, noop 41 | dd exit 42 | 43 | ; ------------------------------------------------------------------------ 44 | ; belongs in comment.f but cant define it there and need it here 45 | 46 | _immediate_ 47 | 48 | colon "\\s", xs 49 | dd dobegin 50 | .L0: 51 | dd floads ; close all in progress floads 52 | dd qwhile, .L1 53 | dd abort_fload 54 | dd dorepeat, .L0 55 | .L1: 56 | dd exit 57 | 58 | ; ======================================================================== 59 | 60 | -------------------------------------------------------------------------------- /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/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/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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/ext/struct.f: -------------------------------------------------------------------------------- 1 | \ struct.f - x4 structure defining words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading struct.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | compiler definitions 9 | 10 | \ ------------------------------------------------------------------------ 11 | \ initilize structure definition 12 | 13 | \ this creates a constant but we dont know its value till we finish 14 | \ the structure 15 | 16 | : struct: ( --- a1 0 ) 17 | 0 const \ create named structure 18 | here cell- \ remember body field address 19 | 0 ; \ current size of structure 20 | 21 | ' struct: alias enum: 22 | 23 | \ ------------------------------------------------------------------------ 24 | 25 | : := ( n1 --- n2 ) dup constant 1+ ; 26 | : /= ( xx n1 --- n2 ) nip := ; 27 | 28 | \ ------------------------------------------------------------------------ 29 | 30 | ' struct: alias enum: 31 | 32 | \ ------------------------------------------------------------------------ 33 | 34 | : := ( n1 --- n2 ) dup constant 1+ ; 35 | : /= ( xx n1 --- n2 ) nip := ; 36 | 37 | \ ------------------------------------------------------------------------ 38 | \ create a named field to index n1 of size n2 39 | 40 | : db ( n1 n2 --- ) 41 | over + swap \ create named structure field offset 42 | create, 43 | ;uses (db) ; 44 | 45 | \ ------------------------------------------------------------------------ 46 | 47 | : dw dup + db ; 48 | : dd cells db ; 49 | 50 | \ ------------------------------------------------------------------------ 51 | \ complete structure definition - backfill struct size constant 52 | 53 | : ;struct ( a1 n1 --- ) 54 | swap ! ; 55 | 56 | ' ;struct alias ;enum 57 | 58 | \ ------------------------------------------------------------------------ 59 | 60 | forth definitions 61 | 62 | \ ======================================================================== 63 | -------------------------------------------------------------------------------- /src/ext/tty.f: -------------------------------------------------------------------------------- 1 | \ tty.f - x4 terminal initialization 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading tty.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | \ terminal extensions (text ui) need this 16 | 17 | : get-tsize \ terminal size can change on the fly too 18 | pad $5413 0 drop \ get window size using ioctl 19 | pad w@ !> rows \ update terminal width and height 20 | pad 2+ w@ !> cols 21 | 22 | #out cols > 23 | if 24 | cols 1- #out ! 25 | then 26 | #line rows > 27 | if 28 | rows 1- #line ! 29 | then ; 30 | 31 | \ ------------------------------------------------------------------------ 32 | 33 | drop ; 36 | : termset ( --- ) intios $5402 0 drop ; 37 | 38 | \ ------------------------------------------------------------------------ 39 | 40 | : init-term ( --- ) 41 | termget \ read stdin tios 42 | intios 3 cells + \ point to c_cflag 43 | dup @ 2dup \ fetch c_cflag 44 | $fffffff4 and swap ! \ set non canonical 45 | termset swap ! \ intios state prior to messing with terminal 46 | 47 | get-tsize \ initialize cols and rows constants 48 | 49 | defers default ; \ link into medium priority init chain 50 | 51 | \ ------------------------------------------------------------------------ 52 | 53 | : reset-term ( --- ) 54 | defers atexit 55 | termset ; 56 | 57 | \ ------------------------------------------------------------------------ 58 | 59 | behead 60 | 61 | \ ======================================================================== 62 | -------------------------------------------------------------------------------- /src/ext/message.f: -------------------------------------------------------------------------------- 1 | \ message.f - x4 software message passing 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading message.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | messages ; 20 | 21 | \ ------------------------------------------------------------------------ 22 | 23 | struct: message 24 | lnode: mp.list 25 | 1 dd mp.vector 26 | ;struct 27 | 28 | \ ----------------------------------------------------------------------- 29 | \ allocate handler a1 for message number n1 30 | 31 | headers> 32 | 33 | : +message ( n1 a1 --- f1 ) 34 | message allocate 0= 35 | if 36 | 2drop false exit 37 | then 38 | 39 | dup>r mp.vector ! \ set address of handler 40 | llist * messages + \ add node to list of handlers for this 41 | r> swap >tail \ message number 42 | true ; 43 | 44 | \ ------------------------------------------------------------------------ 45 | \ remove handler a1 for message number n1 46 | 47 | : -message ( n1 a1 --- f1 ) 48 | swap llist * messages + 49 | head@ 50 | 51 | begin 52 | 2dup mp.vector @ <> 53 | while 54 | next@ 55 | dup parent@ head@ over = 56 | until 57 | 2drop false 58 | else 59 | nip message 66 | llist * messages + head@ 67 | ?dup 0= ?exit 68 | 69 | begin 70 | dup mp.vector @ execute 71 | next@ ?dup 0= 72 | until ; 73 | 74 | \ ------------------------------------------------------------------------ 75 | 76 | behead 77 | 78 | \ ======================================================================== 79 | -------------------------------------------------------------------------------- /src/ext/vocabs.f: -------------------------------------------------------------------------------- 1 | \ vocabs.f - extensions to fortgs vocabulary manipulation words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading vocabs.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | root definitions 9 | 10 | \ ------------------------------------------------------------------------ 11 | \ make specified vocabulary the only one in context 12 | 13 | : (only) ( a1 --- ) 14 | >body \ point to body of specified vocabulary 15 | context dup 64 \ erase entire context stack 16 | erase 17 | ! \ put specified vocabulary in context 18 | 1 !> #context ; \ set new context stack depth 19 | 20 | \ ------------------------------------------------------------------------ 21 | 22 | : only ['] root (only) ; \ empty context of everything but root voc 23 | : seal ' (only) ; \ seal application into specified vocab 24 | 25 | \ Only is used to set context back to a sane state. one would usually 26 | \ do something like only forth compiler blah to make only root, forth 27 | \ compiler and blah vocabs in context. 28 | \ 29 | \ seal is used to seal an application into its own vocabulary. this locks 30 | \ the application out of all other vocabularies unless there are words 31 | \ within the sealed vocabulary to give you access to the others. 32 | \ This is primarilly used in applications where you still need the 33 | \ ability to create and compile but you do not want the end user to have 34 | \ full control over the forth environment. 35 | 36 | \ ------------------------------------------------------------------------ 37 | \ create a new context stack so you can modify it safely 38 | 39 | : context: 40 | create 64 allot 41 | does> ( --- current context #context ) 42 | dup>r context swap 64 cmove 43 | current context #context 44 | r> !> context ; 45 | 46 | : #context 48 | !> context 49 | !> current ; 50 | 51 | \ ======================================================================== 52 | -------------------------------------------------------------------------------- /src/ext/tui/screen.f: -------------------------------------------------------------------------------- 1 | \ screen.f - x4 text user interface screen handling words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( screen.f ) 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ allocate buffers for screen 8 | 9 | : salloc ( scr --- f1 ) 10 | dup>r scr-size cells \ get byte size of screen 11 | dup 2* allocate \ allocate two buffers for screen 12 | if 13 | dup r@ buffer1! \ set address of buffer 1 14 | + r@ buffer2! \ and 2 15 | true \ return success 16 | else 17 | drop false \ return fail 18 | then 19 | r>drop ; 20 | 21 | \ ------------------------------------------------------------------------ 22 | \ attach window to screen 23 | 24 | headers> 25 | 26 | \ note: reverse order of these? i.e. make it "store window in screen" ish? 27 | 28 | : win-attach ( scr win --- ) 29 | 2dup win-scr! 30 | swap scr.window >tail ; 31 | 32 | \ ------------------------------------------------------------------------ 33 | \ detach a window from its associated screen 34 | 35 | : win-detach ( win --- ) 36 | r scr erase \ erase screen structure 43 | r@ scr-height! \ set dimensions of screen 44 | r@ scr-width! 45 | r> salloc ; \ allocate bcking store 46 | 47 | \ ------------------------------------------------------------------------ 48 | \ create a named screen structure 49 | 50 | : screen: ( --- ) 51 | create scr allot ; 52 | 53 | \ ------------------------------------------------------------------------ 54 | \ close screen - frees buffers, does not close attached windows 55 | 56 | : close-screen 57 | dup scr.buffer1 58 | dup @ free drop off 59 | scr.buffer2 off ; 60 | 61 | \ ======================================================================== 62 | -------------------------------------------------------------------------------- /src/ext/debug/window.f: -------------------------------------------------------------------------------- 1 | \ window.f - x4 debugger windowing code 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( window.f ) 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | : bug-attr! ( color --- ) seewin win-color! ; 9 | 10 | : bug>norm ( --- ) normal bug-attr! seewin dup win>so win>bold ; 11 | : bug>ipattr ( --- ) ipattr bug-attr! seewin dup winbold ; 12 | : bug>csattr ( --- ) csattr bug-attr! seewin dup win>so win>bold ; 13 | : bug>break ( --- ) brkatr bug-attr! seewin dup win>so win>bold ; 14 | 15 | \ ------------------------------------------------------------------------ 16 | 17 | : >bug-attr ( a1 --- ) 18 | #xu csr-ix = 19 | ?: 20 | bug>csattr 21 | bug>norm 22 | 23 | \ breakpoint check here 24 | 25 | app-ip = 26 | ?: 27 | bug>ipattr 28 | noop ; 29 | 30 | \ ------------------------------------------------------------------------ 31 | \ copy viewable part of debugs see window into the code window 32 | 33 | : .seewin 34 | seewin win-cy@ 35 | codewin win-height@ < 36 | csr-line mid-point < or 37 | if 38 | 0 39 | else 40 | codewin win-height@ 41 | mid-point - csr-line + 42 | seewin win-cy@ < 43 | if 44 | csr-line mid-point - 45 | else 46 | seewin win-cy@ 47 | codewin win-height@ - 1+ 48 | then 49 | then 50 | 51 | ( line# --- ) 52 | 53 | seewin win-width@ cells * 54 | seewin win-buff@ + 55 | codewin win-buff@ 56 | codewin win-height@ 57 | codewin win-width@ cells * 58 | cmove ; 59 | 60 | \ ------------------------------------------------------------------------ 61 | \ display debug screen 62 | 63 | : .bscreen 64 | .seewin bscreen .screen 65 | patch ; 66 | 67 | \ ------------------------------------------------------------------------ 68 | 69 | : show-out 70 | app-out 71 | if 72 | off> app-out 73 | outwin win-detach 74 | else 75 | on> app-out 76 | bscreen outwin win-attach 77 | then 78 | bscreen .screen ; 79 | 80 | \ ======================================================================== 81 | -------------------------------------------------------------------------------- /src/ext/debug/info.f: -------------------------------------------------------------------------------- 1 | \ info.f 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( info.f ) 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | : .delay 9 | infowin win-cr 10 | infowin win" Step Delay: " 11 | infowin step-delay s>d <# #s #> wtype ; 12 | 13 | \ ------------------------------------------------------------------------ 14 | \ display name of item were shoing info for 15 | 16 | : .xt-id ( a1 --- ) 17 | >name ?dup \ is word headerless? 18 | if 19 | count lexmask \ no, display it in infowin 20 | infowin -rot wtype 21 | else 22 | infowin win" ???" \ word is headerless 23 | then ; 24 | 25 | \ ------------------------------------------------------------------------ 26 | \ display contents of variable under ip 27 | 28 | : .variable ( a1 --- ) 29 | dup .xt-id >body @ \ display nfa of item being pointed to 30 | infowin win" = " 31 | 0 <# 8 rep # '$' hold #> 32 | infowin -rot wtype \ display string within info window 33 | infowin win-cr ; 34 | 35 | \ ------------------------------------------------------------------------ 36 | \ display contents of defered word under ip 37 | 38 | : .defered 39 | infowin win" ' " \ display tick 40 | dup >body @ \ fetch cfa of word vectored to by deferred 41 | dup ['] newkey = \ dont show debuggers key handler if this 42 | if \ is the key handler we are decompiling 43 | drop old-key \ show applications key handler 44 | then 45 | .xt-id \ show word name vectored to by deferred word 46 | infowin win" is " 47 | .xt-id \ show name of deferred word itself 48 | infowin win-cr ; 49 | 50 | \ ------------------------------------------------------------------------ 51 | \ display contents of item under ip 52 | 53 | : .info 54 | app-ip@ dup ?cfa 55 | case: 56 | ' doconstant opt .variable 57 | ' dovariable opt .variable 58 | ' dodefer opt .defered 59 | dflt 60 | drop 61 | ;case ; 62 | 63 | 64 | \ ======================================================================== 65 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/ext/rnd.f: -------------------------------------------------------------------------------- 1 | \ rnd.f - x4 random number generator 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading rnd.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | >or u>> or ; 18 | 19 | : +>> 2dup 32swap- <<-rot u>>or ; 20 | : <<+ 2dup <<-rot 32swap- u>>or ; 21 | 22 | \ ------------------------------------------------------------------------ 23 | 24 | : seed2@ ( seed1 --- seed1 seed2 ) 25 | SEED2 over $80080000 and 26 | if 27 | dup 10 >> 3 and 28 | <<+ dup !> SEED2 29 | then ; 30 | 31 | \ ------------------------------------------------------------------------ 32 | 33 | : seed2@ ( seed1 --- seed1 seed2 ) 34 | SEED2 over $80080000 and 35 | if 36 | dup 10 >> 3 and 37 | <<+ dup !> SEED2 38 | then ; 39 | 40 | \ ------------------------------------------------------------------------ 41 | 42 | headers> 43 | 44 | : rnd ( n1 --- n2 ) 45 | >r 0 1 46 | begin 47 | ?dup 48 | while 49 | SEED1 dup 1 and 50 | if 51 | seed2@ xor >r 52 | dup>r or 2r> 53 | else 54 | $e30001 +!> SEED2 2+ 55 | then 56 | 1 +>> !> SEED1 2* 57 | repeat 58 | r> mod ; 59 | 60 | \ ------------------------------------------------------------------------ 61 | \ seed rng (consider using /dev/random for this) 62 | 63 | : rand 64 | time@ tv cell+ @ xor 65 | dup !> SEED1 !> SEED2 ; 66 | 67 | \ ------------------------------------------------------------------------ 68 | \ seed random number generator using current time 69 | 70 | 80 | 81 | : 0seed ( --- ) 82 | off> SEED1 off> SEED2 ; 83 | 84 | \ ------------------------------------------------------------------------ 85 | 86 | behead 87 | 88 | \ ======================================================================== 89 | -------------------------------------------------------------------------------- /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/ext/tui/window.f: -------------------------------------------------------------------------------- 1 | \ window.f - x4 console windowing words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( window.f ) 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ allocate buffer for window 8 | 9 | : walloc ( win --- f1 ) 10 | dup win-size \ get number of bytes in window 11 | allocate \ allocate rw/w buffer 12 | if 13 | swap win-buff! \ store buffer address in window structure 14 | true 15 | else 16 | drop false 17 | then ; 18 | 19 | \ ------------------------------------------------------------------------ 20 | \ pop window to front 21 | 22 | headers> 23 | 24 | : win-pop ( win --- ) 25 | dup win-scr@ swap \ get screen window is attached to 26 | dup win-detach \ detach window from screen 27 | win-attach ; \ reattach window to screen (its now in front) 28 | 29 | \ ------------------------------------------------------------------------ 30 | \ set width, height and default attributes in window 31 | 32 | : (window:) ( width height win --- ) 33 | dup>r win erase \ erase structure 34 | r@ win-height! \ set window width and height in structure 35 | r@ win-width! 36 | 37 | \ set default attributes for window 38 | 39 | white r@ win-color! \ white on black 40 | 0 r@ win-attr! \ no bold, underline, standout etc 41 | bl r@ win-blank! \ blank char is a space not a checker 42 | 43 | r> walloc ; \ allocate backing store for window 44 | 45 | \ ------------------------------------------------------------------------ 46 | \ create a named window structure 47 | 48 | : window: ( --- ) 49 | create win allot ; 50 | 51 | \ ------------------------------------------------------------------------ 52 | \ close specified window (does not kill the window structure) 53 | 54 | : close-win ( w --- ) 55 | dup win-scr@ \ is this window attached to a screen? 56 | if 57 | dup win-detach \ if so detach it 58 | then 59 | win.buffer dup @ free \ deallocate window buffer 60 | drop off ; \ window no longer has a buffer 61 | 62 | \ ======================================================================== 63 | -------------------------------------------------------------------------------- /src/ext/ls.f: -------------------------------------------------------------------------------- 1 | \ ls.f - directory reading example 2 | \ ------------------------------------------------------------------------ 3 | 4 | \ ------------------------------------------------------------------------ 5 | \ default directory to list is current directory 6 | 7 | create default-dir ,' .' 0 c, 8 | 9 | \ ------------------------------------------------------------------------ 10 | \ set text color based on file type 11 | 12 | : set-color ( type --- ) 13 | case: 14 | DT_FIFO opt cyan 15 | DT_CHR opt green 16 | DT_DIR opt blue 17 | DT_BLK opt cyan 18 | DT_REG opt white 19 | DT_LINK opt green 20 | DT_SOCK opt cyan 21 | DT_WHT opt cyan 22 | ;case 23 | >fg ; 24 | 25 | \ ------------------------------------------------------------------------ 26 | \ like type but for asciiz strings not counted strings 27 | 28 | : .asciiz ( a1 --- ) 29 | begin 30 | count ?dup 31 | while 32 | emit 33 | repeat 34 | drop ; 35 | 36 | \ ----------------------------------------------------------------------- 37 | 38 | : ?space 39 | #out @ ?: space noop ; 40 | 41 | : .ls ( --- ) 42 | d_name \ get address of file name in structure 43 | strlen #out @ + cols 10 - > \ is current pos + length greater than cols? 44 | ?: cr ?space .asciiz ; \ display files name 45 | 46 | \ ----------------------------------------------------------------------- 47 | \ display directory whose asciiz path name is at top of stack 48 | 49 | : (ls) ( name --- ) 50 | open-dir not ?exit \ open directory, silently exit if cant 51 | 52 | cr 53 | 54 | begin 55 | read-dir \ read next directory entry 56 | while \ while read succeeds 57 | d_type@ set-color \ get file type and set text color 58 | .ls 59 | repeat 60 | cr close-dir \ close directory after reading 61 | white >fg ; \ make sure text color is sane 62 | 63 | \ ----------------------------------------------------------------------- 64 | 65 | : ls 66 | left \ anything left in tib? 67 | if 68 | bl word \ get directory to display 69 | hhere count s>z \ convert string to asciiz 70 | else 71 | default-dir \ tib is empty, default to current dir 72 | then 73 | (ls) ; 74 | 75 | \ ======================================================================== 76 | -------------------------------------------------------------------------------- /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/ext/file.f: -------------------------------------------------------------------------------- 1 | \ file.f - x4 file i/o words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading file.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ copy counted string file name a1 to pad as an asciiz string 8 | 9 | : fname>pad ( a1 --- pad ) 10 | count dup>r \ get addr and len of filename 11 | pad swap cmove 12 | r> pad + off \ make filename asciiz 13 | pad ; 14 | 15 | \ ------------------------------------------------------------------------ 16 | \ open filename a1 with permissions n1 17 | 18 | : fopen ( n1 a1 --- fd ) 19 | fname>pad ; 20 | 21 | \ ------------------------------------------------------------------------ 22 | \ close file fd 23 | 24 | : fclose ( fd --- ) 25 | drop ; 26 | 27 | \ ------------------------------------------------------------------------ 28 | \ read n1 bytes from file fd to buffer a1 29 | 30 | \ : fread ( n1 a1 fd --- n2 ) 31 | \ ; \ n2 is number of bytes actually read. 32 | 33 | ' alias fread 34 | 35 | \ ------------------------------------------------------------------------ 36 | \ write n1 chars from buffer a1 to file fd 37 | 38 | \ : fwrite ( n1 a1 fd --- n2 ) 39 | \ ; \ n2 = number of bytes written 40 | 41 | ' alias fwrite 42 | 43 | \ ------------------------------------------------------------------------ 44 | \ read 1 byte from file fd 45 | 46 | : fread1 ( fd --- c1 n1 | 0 ) 47 | >r 48 | 0 sp@ \ allocate read buffer and point to it 49 | 1 swap \ number of bytes to read 50 | r> ; \ n1 = data read, n2 = number bytes read 51 | 52 | \ ------------------------------------------------------------------------ 53 | \ write 1 character c1 to file fd 54 | 55 | : fwrite1 ( c1 fd --- n1 ) 56 | >r \ save fd 57 | sp@ \ point at data to write 58 | 1 swap \ number of bytes to write 59 | r> ; \ n1 = number of bytes actually written 60 | 61 | \ ------------------------------------------------------------------------ 62 | \ create file whose name is at a1 with rwx perms n1 63 | 64 | : fcreate ( n1 a1 --- fd ) 65 | fname>pad ; 66 | 67 | \ ======================================================================== 68 | -------------------------------------------------------------------------------- /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/kernel/parse.s: -------------------------------------------------------------------------------- 1 | ; parse.s 2 | ;------------------------------------------------------------------------- 3 | 4 | _var_ '>in', toin, 0 ; current position within TIB 5 | _var_ '#tib', numtib, 0 ; number of chars in TIB 6 | _var_ "tib", tib, 0 ; address of tib 7 | 8 | ; ------------------------------------------------------------------------ 9 | ; default input source address and char count 10 | 11 | ; ( --- a1 n1 ) 12 | 13 | colon '(source)', psource 14 | dd tib ; get address of terminal input buff 15 | dd numtib ; get char count 16 | dd exit 17 | 18 | ; ------------------------------------------------------------------------ 19 | ; return # characters as yet unparsed in tib 20 | 21 | ; ( --- n1 ) 22 | 23 | colon 'left', left 24 | dd numtib ; number of chars in tib (total) 25 | dd toin ; how far we have parsed 26 | dd minus ; calculate difference 27 | dd exit 28 | 29 | ; ------------------------------------------------------------------------ 30 | 31 | colon '?refill', qrefill 32 | dd left, qexit ; if there is nothing left to parse out of tib 33 | dd refill ; refill tib from input stream 34 | dd exit 35 | 36 | ; ------------------------------------------------------------------------ 37 | ; parse a word from input, delimited by c1 38 | 39 | ; ( c1 --- a1 n1 ) 40 | 41 | colon 'parse', parse 42 | dd tor 43 | dd source, toin 44 | dd sstring, over, swap 45 | dd rto 46 | dd scan_eol, tor 47 | dd over, minus, dup 48 | dd rto, znotequals, minus 49 | dd zplusstoreto, toin_b 50 | dd exit 51 | 52 | ; ------------------------------------------------------------------------ 53 | ; like parse but skips leading delimiters - used by word 54 | 55 | ; ( c1 --- a1 n1 ) 56 | 57 | colon 'parse-word', parseword 58 | dd tor 59 | dd source, tuck 60 | dd toin, sstring 61 | dd rfetch, skip 62 | dd over, swap 63 | dd rto, scan_eol 64 | dd tor 65 | dd over, minus 66 | dd rot, rto 67 | dd dup, znotequals, plus 68 | dd minus 69 | dd zstoreto, toin_b 70 | dd exit 71 | 72 | ; ------------------------------------------------------------------------ 73 | ; parse string from input. refills tib if empty 74 | 75 | ; ( c1 --- ) 76 | 77 | colon 'word', word_ 78 | dd qrefill 79 | dd parseword ; ( a1 n1 --- ) 80 | dd hhere, strstore ; copy string to hhere 81 | dd exit 82 | 83 | ; ======================================================================== 84 | -------------------------------------------------------------------------------- /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/kernel/expect.s: -------------------------------------------------------------------------------- 1 | ; expect.s 2 | ; ------------------------------------------------------------------------ 3 | 4 | _defer_ 'expect', expect, pexpect 5 | 6 | ; ------------------------------------------------------------------------ 7 | ; process input of a backspace character 8 | 9 | ; ( #sofar --- 0 | #sofar-1 ) 10 | 11 | colon 'bsin', bsin 12 | dd dup 13 | dd zequals, qexit 14 | dd oneminus ; decrement #sofar 15 | dd pbs, space, pbs ; rub out 1 char left 16 | dd exit 17 | 18 | ; ------------------------------------------------------------------------ 19 | 20 | ; ( max adr #sofar char --- max adr max ) 21 | 22 | colon 'cr-in', crin 23 | dd drop 24 | dd duptor ; remember # recieved chars 25 | dd zstoreto, numtib_b 26 | dd over, rto ; return #sofar = max 27 | dd zequals, qexit 28 | dd space 29 | dd exit 30 | 31 | ; ------------------------------------------------------------------------ 32 | 33 | colon "?bsin", qbsin 34 | dd bs, notequals, qexit 35 | dd bsin 36 | dd exit 37 | 38 | ; ------------------------------------------------------------------------ 39 | 40 | ; ( c1 --- ) 41 | 42 | colon '^char', ctrlchar 43 | dd dup 44 | dd plit, 0ah, equals 45 | dd qcolon 46 | dd crin, qbsin 47 | dd exit 48 | 49 | ; ------------------------------------------------------------------------ 50 | 51 | ; ( adr #sofar char --- adr #sofar ) 52 | 53 | colon 'norm-char', normchar 54 | dd dup3 ; ( a1 n1 c1 a1 n1 c1 --- ) 55 | dd emit ; echo c1 56 | dd plus, cstore ; store c1 at (a1 + n1) 57 | dd oneplus ; increment #sofar 58 | dd exit 59 | 60 | ; ------------------------------------------------------------------------ 61 | ; input n1 chars max to buffer at a1 62 | 63 | ; ( a1 n1 -- ) 64 | 65 | colon '(expect)', pexpect 66 | dd swap, plit, 0 ; ( max adr #sofar --- ) 67 | dd dobegin 68 | .L1: 69 | dd pluck ; get diff between expected and #sofar 70 | dd over, minus ; ( len adr #sofar #left ) 71 | dd qwhile, .L2 ; while #left != 0 72 | dd key, dup ; read key 73 | dd bl_, less ; < hex 20 ? 74 | dd qcolon 75 | dd ctrlchar, normchar 76 | dd dorepeat, .L1 77 | .L2: 78 | dd drop3 ; clear working parameters off stack 79 | dd exit 80 | 81 | ; ------------------------------------------------------------------------ 82 | ; input string of 256 chars max to tib 83 | 84 | colon 'query', query 85 | dd tib, plit, TIBSZ 86 | dd expect ; get 256 chars to tib 87 | dd zoffto,toin_b ; we have parsed zero so far 88 | dd exit 89 | 90 | ; ======================================================================== 91 | -------------------------------------------------------------------------------- /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/kernel/rehash.s: -------------------------------------------------------------------------------- 1 | ; rehash.s 2 | ; ------------------------------------------------------------------------ 3 | 4 | lhead: 5 | dd vlink 6 | 7 | ; ------------------------------------------------------------------------ 8 | ; link header at esi into vocabulary at edi 9 | 10 | link: 11 | mov bh, [esi] ; get nfa hash 12 | and bh, 01fh 13 | mov bl, [esi+1] 14 | add bl, bl 15 | cmp bh, 1 16 | je .L1 17 | add bl, [esi+2] ; add second char to total 18 | add bl, bl ; *2 19 | 20 | .L1: 21 | add bl, bh ; add nfa length to hash 22 | and ebx, 03fh ; there are 64 threads per vocabulary 23 | 24 | shl ebx, 2 ; and 4 bytes per thread entry 25 | add ebx, edi ; point ebx at thread to link into 26 | 27 | mov eax, [ebx] ; get header currently at end of this thread 28 | mov [ebx], esi ; put new header at end of this thread 29 | mov [esi-4], eax ; link new end to old end 30 | ret 31 | 32 | ; ------------------------------------------------------------------------ 33 | ; hashify one vocabulary pointed to by edi 34 | 35 | hashvoc: 36 | xor ecx, ecx ; number of words in thread 0 37 | mov esi, [edi] ; point esi at end of vocabularies thread 0 38 | 39 | ; nasm chained all words onto the first thread. 40 | 41 | .L0: 42 | push esi ; save address of header to rehash 43 | inc ecx ; keep count 44 | mov esi, [esi-4] ; scan back to previous word in thread 45 | or esi, esi ; found the end of the chain ? 46 | jnz .L0 47 | 48 | ; reached end of thread zero. nfas of all words in this thread are now 49 | ; on the stack and ecx it the total thereof 50 | 51 | .L1: 52 | mov dword [edi], 0 ; erase first chain of vocabulary 53 | .L2: 54 | pop esi ; get nfa of header to hash 55 | call link ; link it to one of the threads 56 | dec ecx ; count down 57 | jne .L2 ; and... 58 | ret 59 | 60 | ; ------------------------------------------------------------------------ 61 | 62 | _rehash: 63 | mov eax, noop ; neuter this word so it can never be run 64 | mov dword [rehash_b], eax ; again 65 | 66 | push esi ; save ip 67 | push ebx ; save top of parameter stack 68 | mov edi, dword [voclink_b] ;edi points to first vocabulary to rehash 69 | 70 | .L0: 71 | call hashvoc ; hashify one vocabulary 72 | mov edi, dword [edi+256] ; get address of next vocabulary 73 | or edi, edi ; end of vocabulary chain ? 74 | jnz .L0 75 | 76 | pop ebx ; yes... restore top of stack and ip 77 | pop esi 78 | next 79 | 80 | ; ======================================================================== 81 | -------------------------------------------------------------------------------- /src/ext/tui/border.f: -------------------------------------------------------------------------------- 1 | \ border.f - draw border around a window 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( border.f ) forth cr terminal 5 | 6 | \ ------------------------------------------------------------------------ 7 | \ given x and y calculate screen index 8 | 9 | r nip 1+ r> ; 25 | 26 | \ ------------------------------------------------------------------------ 27 | 28 | : (.bline) 29 | 3dup bemit 30 | >r 1+ r> ; 31 | 32 | \ ------------------------------------------------------------------------ 33 | 34 | : .bline ( c1 c2 c3 ix win --- ) 35 | 3dup bemit ix++ 36 | dup win-width@ rep (.bline) 37 | rot drop bemit ; 38 | 39 | \ ------------------------------------------------------------------------ 40 | \ draw top line of box in window 41 | 42 | : .top ( ix win --- ) 43 | 2>r 'k' 'q' 'l' 2r> 44 | .bline ; 45 | 46 | \ ------------------------------------------------------------------------ 47 | \ draw left and right edges of box in window 48 | 49 | : (.middle) ( ix win --- ) 50 | 'x' -rot 3dup bemit 51 | dup win-width@ 1+ rot + swap 52 | bemit ; 53 | 54 | \ ------------------------------------------------------------------------ 55 | 56 | : .middle ( win --- ) 57 | >r 0 58 | begin 59 | r@ win-xco@ 1- 60 | over r@ win-yco@ + 61 | r@ win-scr@ b-at 62 | r@ (.middle) 63 | 1+ dup r@ win-height@ = 64 | until 65 | r> 2drop ; 66 | 67 | \ ------------------------------------------------------------------------ 68 | \ draw bottom line of box in window w 69 | 70 | : .bottom ( ix win --- ) 71 | 2>r 'j' 'q' 'm' 2r> 72 | .bline ; 73 | 74 | \ ------------------------------------------------------------------------ 75 | 76 | : ((.borders)) 77 | dup win-battr@ swap 78 | dup>r win-xco@ 1- 79 | r@ win-yco@ 1- 80 | r@ win-scr@ b-at 81 | r@ .top 82 | r@ .middle 83 | 84 | r@ win-xco@ 1- 85 | r@ win-yco@ r@ win-height@ + 86 | r@ win-scr@ b-at 87 | r@ .bottom 88 | r> win-attr! ; 89 | 90 | \ ------------------------------------------------------------------------ 91 | \ draw border round window (before drawing window contents 92 | 93 | : (.borders) ( win --- ) 94 | dup ?boxed 95 | ?: 96 | ((.borders)) drop ; 97 | 98 | \ ------------------------------------------------------------------------ 99 | 100 | ' (.borders) is .borders 101 | 102 | \ ======================================================================== 103 | -------------------------------------------------------------------------------- /src/ext/status.f: -------------------------------------------------------------------------------- 1 | \ status.f - x4 displays status in top line 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading status.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | forth definitions 9 | 10 | \ ------------------------------------------------------------------------ 11 | 12 | 20 | 21 | : staton ( --- ) 22 | on> status \ we are displaying status info now 23 | sc 1 rows 1- csr \ set scroll region 24 | rc ; 25 | 26 | \ ------------------------------------------------------------------------ 27 | \ turn status line off - scroll through status line is ok now 28 | 29 | : statoff ( --- ) 30 | off> status \ status not being displayed 31 | sc 0 rows 1- csr \ set scroll region 32 | rc ; 33 | 34 | \ ------------------------------------------------------------------------ 35 | \ display free list space, display free head space 36 | 37 | : .lfree ( --- ) head0 here - ?' base >r hex 7 .r r> radix ; 38 | : .hfree ( --- ) thead hhere - ?' base >r hex 7 .r r> radix ; 39 | 40 | \ ------------------------------------------------------------------------ 41 | 42 | 53 | if 54 | 7 - spaces 55 | cyan >fg ." MIMIV " 56 | else 57 | 1- spaces 58 | then ; 59 | 60 | \ ------------------------------------------------------------------------ 61 | \ display status line in row 1 62 | 63 | : (.status) 64 | status 0= \ do not show status bar if status is disabled 65 | floads 0<> or ?exit \ or if we are floading 66 | 67 | sc #out @ #line @ 68 | base dup>r attrib 69 | 70 | 0 >pref 71 | white blue >color >attrib 72 | 0 0 at 73 | 74 | decimal curoff 75 | statline count type 76 | yellow >fg >bold 77 | 5 hpa .lfree 78 | 17 hpa .hfree 79 | 31 hpa depth 4 - 4 .r 80 | 41 hpa r> 2 .r space 81 | green >fg .date 82 | ?.mimiv 83 | 84 | curon 85 | dup $ff and >attrib 86 | 8 >> >pref 87 | radix #line ! #out ! 88 | rc ; 89 | 90 | \ ------------------------------------------------------------------------ 91 | 92 | 93 | ' (.status) 94 | is .status 95 | 96 | \ ------------------------------------------------------------------------ 97 | 98 | ( mem-blk --- mem-blk ) 26 | dup b.addr@ \ get address of region above one to free 27 | over b.size@ + 28 | dup cell+ @ f-magic = \ is it also an un-allocated region? 29 | if 30 | 16 + @meta r \ retain mem-blks parent heap address 54 | \ unlink from allocated map, merge adjacent 55 | 56 | dup b.size@ \ fetch merged size of block being freed 57 | r@ h.psize @ = \ fetch size of heaps pool 58 | if \ if they are the same 59 | drop r> destry-heap \ return entire heap pool to BIOS (linux) 60 | else \ otherwise 61 | r> h.mapf@ \ link deallocated block to heaps free 62 | swap add-free \ blocks mem-map 63 | then 64 | 65 | true ; \ return success 66 | 67 | \ ------------------------------------------------------------------------ 68 | 69 | headers> 70 | 71 | : free ( addr --- f1 ) 72 | @meta (free) ; \ convert addr to mem-blk and deallocate 73 | 74 | \ ======================================================================== 75 | -------------------------------------------------------------------------------- /src/ext/utils/seaio/test.f: -------------------------------------------------------------------------------- 1 | \ seaio api test functions 2 | \ ------------------------------------------------------------------------ 3 | 4 | fload src/utils/ioctl.f 5 | fload src/seaio/structures.f 6 | fload src/seaio/seaio.f 7 | 8 | \ ------------------------------------------------------------------------ 9 | 10 | : blah 11 | decimal 12 | 0 SD.model u. cr \ = 0 13 | 0 SD.totalports u. cr \ = 4 14 | 0 SD.readable u. cr \ = 8 15 | 0 SD.writeable u. cr \ = 12 16 | 0 SD.io_base u. cr \ = 16 17 | 0 SD.io_addr_size u. cr \ = 20 18 | 0 SD.irq_level u. cr \ = 24 19 | 0 SD.interrupt_control_port u. cr \ = 28 20 | 0 SD.input u. cr \ = 44 21 | 0 SD.output u. cr \ = 84 22 | 0 SD.control u. cr \ = 148 23 | 0 SD.dwSampleInterval u. cr \ = 188 24 | 0 SD.controlwords u. cr \ = 192 25 | 0 SD.ucAIRange u. cr \ = 212 26 | 0 SD.readsInverted u. cr \ = 220 27 | 0 SD.bus_type u. cr \ = 221 28 | ; 29 | 30 | \ ------------------------------------------------------------------------ 31 | 32 | create fn ," /dev/dio0" 33 | 34 | create sea-state ADAPTER_STATE allot 35 | create sea-info ADAPTER_INFO allot 36 | 37 | 0 var fd 38 | 39 | \ ------------------------------------------------------------------------ 40 | 41 | : set-channels 42 | MAXAICHANNELS 0 43 | do 44 | RANGE_0_TO_5 45 | sea-state AS.ucAIRange i + c! 46 | loop ; 47 | 48 | \ ------------------------------------------------------------------------ 49 | 50 | : seaio-close 51 | defers atexit 52 | fd fclose ; 53 | 54 | \ ------------------------------------------------------------------------ 55 | 56 | : seaio-open ( --- ) 57 | fd ?dup if drop off> fd then 58 | 59 | 2 fn fopen dup -1 = ?exit !> fd 60 | 61 | sea-state fd SeaIo_GetAdapterState drop 62 | sea-info fd SeaIo_GetAdapterInfo . ; 63 | 64 | \ ------------------------------------------------------------------------ 65 | 66 | : init 67 | seaio-open set-channels 68 | $80 sea-state AS.ucModeCW c! 69 | sea-state fd SeaIo_SetAdapterState ; 70 | 71 | \ ------------------------------------------------------------------------ 72 | 73 | : rclose ( n1 --- ) fd SeaIo_RelayClose drop ; 74 | : ropen ( n1 --- ) fd SeaIo_RelayOpen drop ; 75 | 76 | \ ------------------------------------------------------------------------ 77 | 78 | : step-left ( --- ) 79 | 16 0 80 | do 81 | i ropen 10 ms 82 | i rclose 10 ms 83 | loop ; 84 | 85 | \ ------------------------------------------------------------------------ 86 | 87 | : step-right 88 | 0 16 89 | do 90 | i ropen 50 ms 91 | i rclose 50 ms 92 | -1 +loop ; 93 | 94 | \ ------------------------------------------------------------------------ 95 | 96 | : all-on 16 0 do i rclose loop ; 97 | : all-off 16 0 do i ropen loop ; 98 | 99 | \ ------------------------------------------------------------------------ 100 | 101 | : xtest 102 | init 10 0 103 | do 104 | step-left 105 | step-right 106 | loop 107 | all-on 10 seconds 108 | all-off ; 109 | 110 | \ ======================================================================== 111 | -------------------------------------------------------------------------------- /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/kernel/reloc.s: -------------------------------------------------------------------------------- 1 | ; reloc.1 - x4 head space relocation words 2 | ; ------------------------------------------------------------------------ 3 | 4 | ; ------------------------------------------------------------------------ 5 | 6 | rethread: 7 | push esi 8 | mov esi, [voclink_b] ; point to first vocabulary 9 | .L0: 10 | mov ecx, 64 ; number of threads in vocabulary 11 | .L1: 12 | cmp edx, [esi] ; is start of this thread the header we just 13 | jne .L2 ; relocated? 14 | mov [esi], ebp ; yes - point thread at headers new address 15 | .L2: 16 | add esi, byte CELL ; point to next thread 17 | loop .L1 18 | mov esi, [esi] ; link back to next vocabulary 19 | cmp esi, 0 ; no more vocabs ? 20 | jne .L0 21 | pop esi 22 | ret 23 | 24 | ; ------------------------------------------------------------------------ 25 | 26 | hreloc: 27 | mov eax, [esi] ; get soruce link field 28 | cmp eax, 0 ; start of thread ? 29 | jz .L0 30 | mov eax, [eax-4] 31 | .L0: 32 | stosd ; save link in destination 33 | mov [esi], edi ; save where this header gets relocated to 34 | add esi, byte 4 35 | mov ebp, edi ; and destination nfa too 36 | mov edx, esi ; remember source nfa hdr we just relocated 37 | movzx ecx, byte [esi] 38 | mov eax, ecx 39 | and ecx, LEX 40 | inc ecx 41 | rep movsb ; relocate nfa 42 | and eax, ALIAS ; is this an alias ? 43 | jnz .L2 44 | mov eax, [esi] ; get cfa of this word 45 | mov [eax-4], ebp ; point cfa-4 at new header location 46 | .L2: 47 | movsd ; relocate cfa pointer 48 | ret 49 | 50 | ; ------------------------------------------------------------------------ 51 | ; relocate all headers to address edi 52 | 53 | relocate: 54 | call hreloc ; relocate one header 55 | call rethread ; check all threads of all vocabs for relocated 56 | cmp edx, ebx ; finished ? 57 | jne relocate 58 | ret 59 | 60 | ; ------------------------------------------------------------------------ 61 | ; relocate all headers to allocated head space 62 | 63 | unpack: 64 | push ebp 65 | mov eax, [turnkeyd_b] ; are there any headers to relocate ? 66 | or eax, eax 67 | jnz .L0 68 | 69 | mov esi, [dp_b] ; get address of end of list space 70 | mov edi, [hp_b] ; where to relocate to 71 | mov ebx, [lhead] ; address of last header defined 72 | 73 | call relocate 74 | 75 | mov [lhead], ebp ; save address of highest header in memory 76 | mov [hp_b], edi ; correct h-here 77 | 78 | .L0: 79 | pop ebp 80 | ret 81 | 82 | ; ------------------------------------------------------------------------ 83 | ; relocate all headers to here. point here at end of packed headers 84 | 85 | code 'pack', pack 86 | push ebx ; retain cached top of stack 87 | push esi ; and interprative pointer 88 | push ebp 89 | mov esi, [bhead_b] ; point to start of head space 90 | mov edi, [dp_b] ; point to reloc destination 91 | mov ebx, [last_b] 92 | call relocate ; relocate all headers 93 | mov [hp_b], edi 94 | mov [lhead], ebp 95 | pop ebp 96 | pop esi 97 | pop ebx 98 | next 99 | 100 | ;========================================================================= 101 | -------------------------------------------------------------------------------- /src/ext/words.f: -------------------------------------------------------------------------------- 1 | \ words.f - x4 vocabulary listing words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading words.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | \ if enough people request that i add color to different word types and 9 | \ can tell me how to colorize user defined word classes i might do it :P 10 | \ 11 | \ might also add substring searches so we can find all words that contain 12 | \ a substring... eventually 13 | 14 | \ ------------------------------------------------------------------------ 15 | 16 | \ past max column 38 | if 39 | .idcr ?more \ yes - go to start of next line 40 | then 41 | type space ; \ display this word name 42 | 43 | \ ------------------------------------------------------------------------ 44 | \ display nfa of word given its cfa 45 | 46 | : .id ( a1 --- ) 47 | >name ?dup 48 | ?: 49 | (.id) .noname ; 50 | 51 | \ ------------------------------------------------------------------------ 52 | \ display al words in a given vocabulary thread 53 | 54 | : ((words)) ( thread --- ) 55 | begin 56 | dup (.id) \ display name of current header 57 | n>link @ \ link back to previous header 58 | ?dup 0= \ till we run out of previous headers 59 | until ; 60 | 61 | \ ------------------------------------------------------------------------ 62 | \ display all words in specified vocabulary 63 | 64 | : (words) 65 | #threads 0 \ for the total nunber of threads ina voc do 66 | do 67 | dcount ?dup \ fetch thread. and while its not empty 68 | if 69 | ((words)) \ display all the words in that thread 70 | then 71 | mkey $1b = ?leave \ repeat unless someone hit escape 72 | loop 73 | drop ; 74 | 75 | \ ------------------------------------------------------------------------ 76 | \ display all words in context 77 | 78 | headers> 79 | 80 | : words 81 | rows 3 - !> idx0 82 | cols !> idw \ set max width (see utils.f) 83 | idx0 !> idx 84 | ['] cr is .idcr 85 | cr cr white >fg bold 93 | '[' emit type ']' emit 94 | d', stod 59 | push ebx ; push d1 low = n1 60 | add ebx, ebx ; shift sign bit into carry 61 | sbb ebx, ebx ; propogates sign of n1 throughout d1 high 62 | next 63 | 64 | ; ------------------------------------------------------------------------ 65 | ; compare 2 double numbers 66 | 67 | ; ( d1 d2 --- f1 ) 68 | 69 | 70 | colon 'd=', dequals 71 | dd dminus ; stubract d2 from d1 72 | dd orr ; or together high and low of result 73 | dd zequals ; result will only be 0 when d1 = d2 74 | dd exit 75 | 76 | ; ------------------------------------------------------------------------ 77 | ; is double number negative? 78 | 79 | ; ( d1 --- f1 ) 80 | 81 | code 'd0<', dzlezz 82 | add ebx, ebx ; shift sign bit into carry 83 | sbb ebx, ebx ; propogates sign of n1 throughout d1 high 84 | pop eax 85 | next 86 | 87 | ; ------------------------------------------------------------------------ 88 | ; see if double d1 is less than double d2 89 | 90 | ; ( d1 d2 --- f1 ) 91 | 92 | code 'd<', dless 93 | pop eax 94 | pop ecx 95 | cmp [esp], eax 96 | pop eax 97 | sbb ecx, ebx 98 | mov ebx, 0 99 | jge .L1 100 | dec ebx 101 | .L1: 102 | next 103 | 104 | ; ------------------------------------------------------------------------ 105 | 106 | ; ( d1 d2 --- f1 ) 107 | 108 | colon 'd>', dgreater 109 | dd swap2 110 | dd dless 111 | dd exit 112 | 113 | ; ------------------------------------------------------------------------ 114 | 115 | ; ( d1 d2 --- f1 ) 116 | 117 | colon 'd<>', dnotequals 118 | dd dequals 119 | dd nott 120 | dd exit 121 | 122 | ; ======================================================================== 123 | -------------------------------------------------------------------------------- /src/ext/datetime/timer.f: -------------------------------------------------------------------------------- 1 | \ timer.f - x4 elapsed time measurement and delay words 2 | \ ------------------------------------------------------------------------ 3 | 4 | .( loading timer.f ) cr 5 | 6 | \ ------------------------------------------------------------------------ 7 | 8 | create tv 0 , 0 , \ long tv_sec long tv_usec 9 | 10 | takes 2 parmeters 17 | 18 | headers> 19 | 20 | 2 78 syscall \ tz tv 21 | 22 | \ ------------------------------------------------------------------------ 23 | \ these are elapsed time timers. not signal timers 24 | 25 | 35 | 36 | : time@ ( --- seconds-since-epoc ) 37 | tz tv \ syscall takes 2 parameters 38 | \ time val and time zone structure addresses 39 | drop \ bleh - it worked! 40 | tv @ ; \ get returned value 41 | 42 | \ ------------------------------------------------------------------------ 43 | \ fetch current time in seconds/useconds 44 | 45 | 55 | 56 | : timer-reset 57 | tstack >r tv@ 58 | r@ [].push drop 59 | r> [].push drop ; 60 | 61 | \ ------------------------------------------------------------------------ 62 | \ factored out just to confuse you :) 63 | 64 | 79 | 80 | : .elapsed 81 | tstack >r tv@ 82 | r@ [].pop drop 83 | r> [].pop drop d- 84 | 85 | base >r decimal 86 | 87 | <# 0 # drop 0 # drop 88 | 0 # 2drop '.' hold 89 | 90 | (t) (t) 91 | 60m #> type drop 92 | r> radix ; 93 | 94 | \ ------------------------------------------------------------------------ 95 | \ allocate nanosleep syscall 96 | 97 | 2 162 syscall 98 | 99 | \ ------------------------------------------------------------------------ 100 | 101 | 0= 106 | until ; 107 | 108 | \ ------------------------------------------------------------------------ 109 | \ delay n1 seconds 110 | 111 | headers> 112 | 113 | : seconds ( n1 --- ) 114 | sec ! 115 | [ sec cell+ ]# off 116 | (nano) ; 117 | 118 | \ ------------------------------------------------------------------------ 119 | \ delay n1 microseconds 120 | 121 | : ms ( n1 --- ) 122 | 1000 /mod sec ! 123 | 1000000 * [ sec cell+ ]# ! 124 | (nano) ; 125 | 126 | \ ======================================================================== 127 | -------------------------------------------------------------------------------- /src/ext/macros/inline.f: -------------------------------------------------------------------------------- 1 | \ inline.f - x4 macro creation and inlining 2 | \ ------------------------------------------------------------------------ 3 | 4 | \ ------------------------------------------------------------------------ 5 | 6 | r , \ save true for exit and compile the " token 25 | count -1 /string \ get string length and address 26 | 2dup s, + r> ; \ compile string, advance addr, return true 27 | 28 | \ ------------------------------------------------------------------------ 29 | \ words that have a branch vector compiled after them 30 | 31 | \ it is assumed that a branch vector is absolute, not relative 32 | \ - this is a true assumption in x4 - 33 | 34 | create branches 35 | ] 36 | (nxt) (do) (?do) doif doelse (loop) 37 | (+loop) dobegin ?while dorepeat doagain ?until 38 | [ 12 const #branches 39 | 40 | \ ------------------------------------------------------------------------ 41 | \ is the current token a branching type word? 42 | 43 | : is-branch? ( token --- f1 ) 44 | branches #branches pluck \ search above table for specified token 45 | dscan nip 0= not 46 | !> was-branch ; \ indicate next xt is the branch vector 47 | 48 | \ ------------------------------------------------------------------------ 49 | \ expand a token from a macro into its target definition 50 | 51 | : ((m:)) ( a1 token --- a2 ) 52 | is-quote? ?exit \ handle " token if it is one, exit if it was 53 | was-branch \ was the previous token a branch? 54 | if 55 | off> was-branch \ clear flag 56 | m-start - m-new + \ relocate branch vector 57 | else 58 | is-branch? \ is the current token a branch? 59 | then 60 | , ; \ compile token, advance address 61 | 62 | \ ------------------------------------------------------------------------ 63 | 64 | : (m:) 65 | dcount !> m-exit \ fetch the compiled exit point of macro 66 | dup !> m-start \ point to body of macro 67 | here !> m-new \ fetch address to inline macro to 68 | 69 | begin 70 | dup m-exit <> \ reached end of macro? 71 | while 72 | dcount ((m:)) \ no - fetch and process next token 73 | repeat 74 | drop ; \ yes - clean up 75 | 76 | \ ------------------------------------------------------------------------ 77 | \ start a macro colon definition 78 | 79 | headers> 80 | 81 | : m: 82 | inline> \ initialize macro compilation 83 | create immediate \ create new word and make it immediate 84 | >mark \ compile dummy macro exit point 85 | ] \ switch into compile mode 86 | does> (m:) ; \ patch macros cfa 87 | 88 | \ ------------------------------------------------------------------------ 89 | \ complete definition of a macro colon definition 90 | 91 | : ;m 92 | >resolve \ compile exit point of macro 93 | [compile] -; \ switch out of compile mode 94 | 39 | 40 | : .free ( --- ) 41 | heaps head@ dup 0= 42 | if 43 | 10 u.r exit 44 | then 45 | 46 | begin 47 | dup ?largest 10 u.r 48 | next@ ?dup 0= 49 | until ; 50 | 51 | \ ------------------------------------------------------------------------ 52 | \ memory debug info display 53 | 54 | buffs 75 | dup b.size@ +!> total 76 | next@ 77 | repeat ; 78 | 79 | \ ------------------------------------------------------------------------ 80 | \ total up all mem-blks in a mem-map 81 | 82 | : ?total ( mem-map --- total ) 83 | off> total 84 | off> buffs 85 | 16 86 | for 87 | dup head@ (?total) 88 | llist + 89 | nxt 90 | drop total ; 91 | 92 | \ ------------------------------------------------------------------------ 93 | 94 | : .n .r space .| ; 95 | 96 | \ ------------------------------------------------------------------------ 97 | 98 | : .header 99 | cr bar 100 | ." | heap | Largest | total | total | free " 101 | ." | allocd | cached | total |" cr 102 | ." | num | buffer | free | used | blocks " 103 | ." | blocks | dscrip | dscrip |" cr 104 | bar ; 105 | 106 | \ ------------------------------------------------------------------------ 107 | 108 | : .heap-info ( heap --- ) 109 | .| h 4 .n dup>r 110 | ?largest 8 .n 111 | 112 | r@ h.mapf@ ?total 8 .n buffs 113 | r@ h.mapa@ ?total 8 .n buffs 114 | swap 6 .n 6 .n 115 | 116 | off> buffs 117 | 118 | r@ h.cached head@ 119 | (?total) buffs 6 .n 120 | 121 | r> h.bcount @ 6 .n ; 122 | 123 | \ ------------------------------------------------------------------------ 124 | 125 | headers> 126 | 127 | : .mem-info ( --- n1 ) 128 | 1 !> h .header 129 | 130 | heaps head@ 131 | begin 132 | ?dup 133 | while 134 | dup>r .heap-info cr 135 | incr> h 136 | r> next@ 137 | repeat 138 | bar ; 139 | 140 | \ ------------------------------------------------------------------------ 141 | 142 | : ?mem-info ( heap --- largest free alloc fd fa fc ft ) 143 | dup>r ?largest 144 | r@ h.mapf@ ?total buffs 145 | r@ h.mapa@ ?total swap buffs 146 | 147 | off> buffs 148 | r@ h.cached head@ (?total) 149 | buffs 150 | 151 | r> h.bcount @ ; 152 | 153 | \ ======================================================================== 154 | -------------------------------------------------------------------------------- /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