├── .gitignore
├── Editor.md
├── LICENSE
├── README.md
├── block-003.fth
├── block-004.fth
├── block-005.fth
├── block-006.fth
├── block-007.fth
├── block-008.fth
├── block-010.fth
├── block-020.fth
├── block-021.fth
├── block-022.fth
├── block-023.fth
├── block-024.fth
├── block-025.fth
├── block-026.fth
├── block-049.fth
├── block-050.fth
├── block-051.fth
├── block-200.fth
├── block-201.fth
├── block-202.fth
├── c4.c
├── c4.h
├── c4.sln
├── c4.vcxproj
├── editor.c
├── file-pc.c
├── makefile
├── sys-load.c
└── system.c


/.gitignore:
--------------------------------------------------------------------------------
 1 | c4
 2 | c4-32
 3 | /block-99?.fth
 4 | /x64
 5 | /Debug
 6 | /Release
 7 | /c4.vcxproj.user
 8 | .vscode
 9 | /enc_temp_folder/
10 | 


--------------------------------------------------------------------------------
/Editor.md:
--------------------------------------------------------------------------------
  1 | # The c4 editor
  2 | 
  3 | The c4 editor is somewhat similar to a stripped-down version of VI. <br/>
  4 | Enable the editor using `#define EDITOR` (in c4.h) <br/>
  5 | The current block being edited is in 'block@'. <br/>
  6 | Use '23 edit' to edit block #23. <br/>
  7 | Use 'ed' to re-edit the last edited block. </br>
  8 | While in the editor, use ':!5 block!' to switch to another block. <br/>
  9 | 
 10 | ## Modes
 11 | There are 4 modes in the editor:
 12 | - NORMAL
 13 | - INSERT
 14 | - REPLACE
 15 | - COMMAND
 16 | 
 17 | ### These control keys are active in all modes:
 18 | 
 19 | | Key         | Action |
 20 | | :--         | :-- |
 21 | | [ctrl]+a    | Insert/replace tag: COMPILE |
 22 | | [ctrl]+b    | Insert/replace tag: DEFINE |
 23 | | [ctrl]+c    | Insert/replace tag: INTERP |
 24 | | [ctrl]+d    | Insert/replace tag: COMMENT |
 25 | | [ctrl]+e    | Send the current line to the outer interpreter |
 26 | | [ctrl]+h    | Left 1 char (and delete it if in INSERT mode) |
 27 | | [ctrl]+i    | Right 8 chars (also [tab]) |
 28 | | [shift]+tab | Left 8 chars |
 29 | | [ctrl]+j    | Down 1 line |
 30 | | [ctrl]+k    | Up 1 line |
 31 | | [ctrl]+l    | Right 1 char |
 32 | | [ctrl]+q    | Left 8 chars |
 33 | | [ctrl]+s    | Save the block to disk |
 34 | | [ctrl]+Home | Goto the beginning of the first line |
 35 | | [ctrl]+End  | Goto the beginning of the last line |
 36 | | [ctrl]+x    | Delete the char under the cursor |
 37 | | [esc-esc]   | Goto NORMAL mode |
 38 | 
 39 | ### NORMAL mode
 40 | 
 41 | | Key  | Action|
 42 | | :--  | :-- |
 43 | | $    | Goto the end of the line |
 44 | | _    | Goto the beginning of the line |
 45 | | [CR] | Goto the beginning of the next line |
 46 | | [SP] | Right 1 char |
 47 | | 1    | Set tag: COMPILE |
 48 | | 2    | Set tag: DEFINE |
 49 | | 3    | Set tag: INTERP |
 50 | | 4    | Set tag: COMMENT |
 51 | | :    | Change to COMMAND mode |
 52 | | +    | Save the current block and goto the next block |
 53 | | -    | Save the current block and goto the previous block |
 54 | | /    | Specify search string, jump to next occurrence |
 55 | | #    | Redraw the screen |
 56 | | a    | Append: move right 1 char and change to INSERT mode (same as 'li') |
 57 | | A    | Append: goto the end of the line and change to INSERT mode  (same as '$i') |
 58 | | b    | Insert a BLANK/SPACE into the current line |
 59 | | B    | Insert a BLANK/SPACE to the end of the block |
 60 | | c    | Change: Delete the current char and change to INSERT mode (same as 'xi') |
 61 | | C    | Change: Delete to the end of the line and change to INSERT mode (same as 'd$i') |
 62 | | d.   | Delete the char under the cursor (same as 'x') |
 63 | | d$   | Delete to the end of the line |
 64 | | dd   | Copy the current line into the YANK buffer and delete the line |
 65 | | dw   | Delete the current word |
 66 | | D    | Delete to the end of the line (same as 'd$') |
 67 | | g    | Goto the top-left of the screen |
 68 | | G    | Goto the bottom-left of the screen |
 69 | | h    | Left 1 char |
 70 | | i    | Change to INSERT mode |
 71 | | I    | Goto the beginning of the line and change to INSERT mode (same as '_i') |
 72 | | j    | Down 1 line |
 73 | | J    | Join the current and next lines together |
 74 | | k    | Up 1 line |
 75 | | l    | Right 1 char |
 76 | | m    | Down 4 lines |
 77 | | M    | Up 4 lines |
 78 | | n    | Jump to next occurrence of search string |
 79 | | N    | Jump to previous occurrence of search string |
 80 | | o    | Insert an empty line BELOW the current line and change to INSERT mode |
 81 | | O    | Insert an empty line ABOVE the current line and change to INSERT mode |
 82 | | p    | Paste the YANK buffer into a new line BELOW the current line |
 83 | | P    | Paste the YANK buffer into a new line ABOVE the current line |
 84 | | q    | Right 4 chars |
 85 | | Q    | Left 4 chars |
 86 | | r    | Replace the char under the cursor with the next key pressed (if printable) |
 87 | | R    | Change to REPLACE mode |
 88 | | S    | Switch to last edited block |
 89 | | w    | Move right to the beginning of the next word |
 90 | | W    | Move left to the beginning of the previous word |
 91 | | x    | Delete the char under the cursor to the end of the line |
 92 | | X    | Delete the char to the left of the cursor (same as 'hx') |
 93 | | Y    | Copy the current line into the YANK buffer |
 94 | | Z    | Delete the char under the cursor to the end of the block |
 95 | 
 96 | ### INSERT mode
 97 | 
 98 | In INSERT mode, all printable characters are inserted into the line.
 99 | - [Enter] inserts a new line at the cursor.
100 | - [Backspace] moves left and deletes that character.
101 | 
102 | ### REPLACE mode
103 | 
104 | In REPLACE mode, all printable characters are placed into the line.
105 | - [Enter] moves to the beginning of the next line.
106 | - [Backspace] moves left and does not delete that character.
107 | 
108 | ### COMMAND mode
109 | 
110 | COMMAND mode is invoked when pressing ':' in NORMAL mode.
111 | 
112 | | Command | Action|
113 | | :--     | :-- |
114 | | rl      | ReLoad: discard all changes and reload the current block |
115 | | w       | Write the current block if it has changed |
116 | | w!      | Write the current block, even if it has NOT changed |
117 | | wq      | Write the current block and quit (same as ':w' ':q') |
118 | | q       | Quit, if the current block has NOT changed |
119 | | q!      | Quit, even if the current block has changed |
120 | | ![any]  | Send [any] to the c4 outer interpreter |
121 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | MIT License
 2 | 
 3 | Copyright (c) 2024 Chris Curl
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # c4: A portable Forth system inspired by ColorForth and Tachyon
  2 | 
  3 | ## ColorForth's influence on c4
  4 | c4 supports control characters in the whitespace that change the state.<br/>
  5 | c4 has 'A', 'B' and 'T' stacks, inspired by ColorForth's 'a' register.<br/>
  6 | c4 has 4 states: INTERPRET, COMPILE, DEFINE, AND COMMENT,<br/>
  7 | c4 also supports the standard state-change words.<br/>
  8 | 
  9 | | Ascii | Word  | State | Description|
 10 | |:--    |:--    |:--    |:-- |
 11 | |  $01  |  ]    |   1   | Compile |
 12 | |  $02  |  :    |   2   | Define |
 13 | |  $03  |  [    |   3   | Interpret/execute/immediate |
 14 | |  $04  |       |   4   | Comment |
 15 | |       |  (    |   4   | Comment, save current state |
 16 | |       |  )    |       | End comment, restores saved state |
 17 | 
 18 | **NOTE**: In the DEFINE state, c4 changes the state to COMPILE after adding the next word.<br/>
 19 | **NOTE**: Unlike ColorForth, ';' compiles EXIT and then changes the state to INTERPRET.<br/>
 20 | 
 21 | ## Tachyon's influence on c4
 22 | In c4, a program is a sequence of WORD-CODEs. <br/>
 23 | A WORD-CODE is a 16-bit unsigned number (a WORD). <br/>
 24 | Primitives are assigned numbers sequentially from 0 to **BYE**. <br/>
 25 | If a WORD-CODE is less than or equal to **BYE**, it is a primitive. <br/>
 26 | If the top 3 bits are set, it is a 13-bit unsigned literal, 0-$1FFF. <br/>
 27 | If it is between **BYE**, and $E000, it is the code address of a word to execute. <br/>
 28 | 
 29 | ## c4's built-in block editor
 30 | c4 has a built-in editor. See **Editor.md** for details. <br/>
 31 | The editor can be excluded from c4 by undefining **EDITOR** in c4.h. <br/>
 32 | It is built-in so that the editor is available when running c4 from any folder. <br/>
 33 | In c4, the size if a block is 3072 bytes (3x1024). <br/>
 34 | The editor is 32 lines, 96 columns, and has a VI like feel. <br/>
 35 | 
 36 | ## Building c4
 37 | ### Windows
 38 | - There is a Visual Studio solution file, c4.sln (either 32- or 64-bit)
 39 | ### Linux and other similar systems
 40 | - There is a makefile.
 41 | - The default architecture is 32-bits. That is faster on my systems.
 42 | - 32-bit: use 'make'
 43 | - 64-bit: use 'ARCH=64 make'
 44 | 
 45 | ## c4 memory usage
 46 | c4 provides a single memory area with size 'mem-sz' (see c4.h, MEM_SZ).
 47 | - It is divided into 3 areas as follows **[CODE][VARS][Dictionary]**.
 48 | - The **CODE** area is an aray of WORD-CODEs starting at the beginning of the memory.
 49 | - The **VARS** area is defined to begin at address **&memory[CODE_SLOTS*WC_SZ]**.
 50 | - The **Dictionary** starts at the end and grows downward.
 51 | - The size of the CODE area is 'code-sz' (see c4.h, CODE_SLOTS).
 52 | - `here` is an offset into the **CODE** area, the next slot to be allocated.
 53 | - `last` is the address of the most recently created word.
 54 | - `vhere` is the address of the first free byte the **VARS** area.
 55 | - Use `->memory` to turn an offset into an address into the memory area.
 56 | - Use `->code` to turn an offset into an address of a WORD-CODE.
 57 | - **NOTE**: CODE slots 0-25 (`0 wc@` .. `25 wc@`) are reserved for c4 system values.
 58 | - **NOTE**: CODE slots 26-BYE (`26 wc@` .. `<bye> wc@`) are unused by c4.
 59 | - **NOTE**: These are free for the application to use as desired.
 60 | - **NOTE**: Use `wc@` and `wc!` to get and set WORD-CODE values in the **CODE** area.
 61 | 
 62 | | WORD    | STACK | DESCRIPTION |
 63 | |:--      |:--    |:-- |
 64 | | memory  | (--A) | A: starting address of the c4 memory |
 65 | | vars    | (--A) | A: starting address of the VARS area |
 66 | | mem-sz  | (--N) | N: size in BYTEs of the c4 memory |
 67 | | code-sz | (--N) | N: size in WORD-CODEs of the c4 CODE area |
 68 | | dstk-sz | (--N) | N: size in CELLs of the DATA and RETURN stacks |
 69 | | tstk-sz | (--N) | N: size in CELLs of the A and T stacks |
 70 | | wc-sz   | (--N) | N: size in BYTEs of a WORD-CODE |
 71 | | de-sz   | (--N) | N: size in BYTEs of a dictionary entry |
 72 | | (dsp)   | (--N) | N: CODE slot for the data stack pointer |
 73 | | (rsp)   | (--N) | N: CODE slot for the return stack pointer |
 74 | | (lsp)   | (--N) | N: CODE slot for the loop stack pointer |
 75 | | (tsp)   | (--N) | N: CODE slot for the T stack pointer |
 76 | | (asp)   | (--N) | N: CODE slot for the A stack pointer |
 77 | | (bsp)   | (--N) | N: CODE slot for the B stack pointer |
 78 | | (here)  | (--N) | N: CODE slot for the HERE variable |
 79 | | (vhere) | (--A) | A: address of the VHERE variable |
 80 | | (last)  | (--A) | A: address of the LAST variable |
 81 | | base    | (--N) | N: CODE slot for the BASE variable |
 82 | | state   | (--N) | N: CODE slot for the STATE variable |
 83 | | (block) | (--N) | N: CODE slot for the BLOCK variable |
 84 | 
 85 | ## c4 Strings
 86 | Strings in c4 are NULL-terminated with no count byte.<br/>
 87 | 
 88 | ## Format specifiers in `ftype` and `."`
 89 | Similar to the printf() function in C, c4 supports formatted output using '%'. <br/>
 90 | For example `: ascii ( n-- ) dup dup dup ." char %c, decimal #%d, binary: %%%b, hex: $%x%n" ;`.
 91 | 
 92 | | Format | Stack | Description |
 93 | |:--     |:--    |:-- |
 94 | | %b     | (N--) | Print TOS in base 2. |
 95 | | %c     | (N--) | EMIT TOS. |
 96 | | %d     | (N--) | Print TOS in base 10. |
 97 | | %e     | (--)  | EMIT `escape` (#27). |
 98 | | %i     | (N--) | Print TOS in the current base. |
 99 | | %n     | (--)  | Print CR/LF (13/10). |
100 | | %q     | (--)  | EMIT a `double-quote` (#34). |
101 | | %s     | (A--) | Print TOS as a string (formatted). |
102 | | %S     | (A--) | Print TOS as a string (unformatted). |
103 | | %x     | (N--) | Print TOS in base 16. |
104 | | %B     | (--)  | Change foreground to Blue |
105 | | %G     | (--)  | Change foreground to Green |
106 | | %P     | (--)  | Change foreground to Purple |
107 | | %R     | (--)  | Change foreground to Reg |
108 | | %W     | (--)  | Change foreground to White |
109 | | %Y     | (--)  | Change foreground to Yellow |
110 | | %[x]   | (--)  | EMIT [x]. |
111 | 
112 | ## The A, B and T stacks
113 | c4 includes A, B and T stacks. <br/>
114 | These are similar to ColorForth's operations for 'a', but in c4, they are stacks.<br/>
115 | The size of the stacks is 'tstk-sz' (see c4.h, TSTK_SZ).<br/>
116 | Note that there are also additional words for the return stack. <br/>
117 | 
118 | | WORD  | STACK | DESCRIPTION |
119 | |:--    |:--    |:-- |
120 | | >a    | (N--) | Push N onto the A stack. |
121 | | a!    | (N--) | Set A-TOS to N. |
122 | | a@    | (--N) | N: copy of A-TOS. |
123 | | a@+   | (--N) | N: copy of A-TOS, then increment A-TOS. |
124 | | a@-   | (--N) | N: copy of A-TOS, then decrement A-TOS. |
125 | | a>    | (--N) | Pop N from the A stack. |
126 | | adrop | (--)  | Drop A-TOS. |
127 | 
128 | ## Inline words
129 | In c4, an "INLINE" word is similar to a macro. When compiling a word that is INLINE, c4 copies the contents of the word (up to, but not including the first EXIT) to the target, as opposed to compiling a CALL to the word. This improves performance, but uses extra space.
130 | 
131 | **Note that if a word might have an embedded 7 (EXIT) in its implementation (eg - a word in an address for example), then it should not be marked as INLINE.**
132 | 
133 | ## Temporary words
134 | c4 provides 10 temporary words, 't0' thru 't9'.
135 | - Defining a temporary word does not add an entry to the dictionary.
136 | - Temporary words are intended to be helpful in factoring code.
137 | - Their names are case-sensitive (t0-t9, not T0-T9).
138 | - A temporary word can be redefined as often as desired.
139 | - When redefined, code references to the previous definition are unchanged.
140 | - t0 thru t5 are 'normal', t6 thru t9 are 'inline'.
141 | 
142 | ## c4 WORD-CODE primitives
143 | The primitives:
144 | 
145 | | WORD      | STACK        | DESCRIPTION |
146 | |:--        |:--           |:-- |
147 | | :         | (--)  ST=2   | Set STATE to DEFINE (RED) |
148 | | ;         | (--)  ST=3   | Compile EXIT and set STATE to INTERPRET (YELLOW) |
149 | | [         | (--)  ST=3   | Set STATE to INTERPRET (YELLOW) |
150 | | ]         | (--)  ST=1   | Set STATE to COMPILE (GREEN) |
151 | | (         | (--)  ST=4   | Remember STATE. Set STATE to COMMENT (WHITE) |
152 | | )         | (--)  ST=?   | Set STATE to previous state |
153 | | (lit)     | (--WC)       | WC: WORD-CODE for the LIT primitive |
154 | | (jmp)     | (--WC)       | WC: WORD-CODE for the JMP primitive |
155 | | (jmpz)    | (--WC)       | WC: WORD-CODE for the JMPZ primitive |
156 | | (jmpnz)   | (--WC)       | WC: WORD-CODE for the JMPNZ primitive |
157 | | (njmpz)   | (--WC)       | WC: WORD-CODE for the NJMPZ primitive |
158 | | (njmpnz)  | (--WC)       | WC: WORD-CODE for the NJMPNZ primitive |
159 | | (exit)    | (--WC)       | WC: WORD-CODE for the EXIT primitive |
160 | | exit      | (--)         | EXIT word |
161 | | dup       | (N--N N)     | Duplicate TOS (Top-Of-Stack) |
162 | | swap      | (X Y--Y X)   | Swap TOS and NOS (Next-On-Stack) |
163 | | drop      | (N--)        | Drop TOS |
164 | | over      | (N X--N X N) | Push NOS |
165 | | @         | (A--N)       | N: the CELL at absolute address A |
166 | | c@        | (A--C)       | C: the CHAR at absolute address A |
167 | | w@        | (A--W)       | W: the 16-bit WORD at absolute address A |
168 | | d@        | (A--D)       | D: the 32-bit DWORD at absolute address A |
169 | | wc@       | (N--WC)      | WC: the WORD-CODE in CODE slot N |
170 | | !         | (N A--)      | Store CELL N to absolute address A |
171 | | c!        | (C A--)      | Store CHAR C to absolute address A |
172 | | w!        | (W A--)      | Store 16-bit WORD W to absolute address A |
173 | | d!        | (D A--)      | Store 32-bit DWORD D to absolute address A |
174 | | wc!       | (WC N--)     | Store WORD-CODE WC to CODE slot N |
175 | | +         | (X Y--N)     | N: X + Y |
176 | | -         | (X Y--N)     | N: X - Y |
177 | | *         | (X Y--N)     | N: X * Y |
178 | | /         | (X Y--N)     | N: X / Y (integer division) |
179 | | /mod      | (X Y--M Q)   | M: X modulo Y, Q: quotient of X / Y |
180 | | 1+        | (X--Y)       | Increment TOS |
181 | | 1-        | (X--Y)       | Decrement TOS |
182 | | +!        | (N A--)      | Add N to the CELL at A |
183 | | <         | (X Y--F)     | F: 1 if (X < Y), else 0 |
184 | | =         | (X Y--F)     | F: 1 if (X = Y), else 0 |
185 | | >         | (X Y--F)     | F: 1 if (X > Y), else 0 |
186 | | 0=        | (N--F)       | F: 1 if (N=0), else 0 |
187 | | and       | (X Y--N)     | N: X AND Y |
188 | | or        | (X Y--N)     | N: X OR  Y |
189 | | xor       | (X Y--N)     | N: X XOR Y |
190 | | com       | (X--Y)       | Y: X with all bits flipped (complement) |
191 | | for       | (CNT--)      | Begin FOR loop with bounds 0 and CNT-1. |
192 | | i         | (--I)        | I: Current FOR loop index. |
193 | | next      | (--)         | Increment I. If I >= CNT, exit, else start loop again. |
194 | | unloop    | (--)         | Unwind the loop stack. **DOES NOT EXIT THE LOOP**. |
195 | | >r        | (N--)        | Push N onto the return stack |
196 | | r!        | (N--)        | Set R-TOS to N |
197 | | r@        | (--N)        | N: copy of R-TOS |
198 | | r@+       | (--N)        | N: copy of R-TOS, then increment it |
199 | | r@-       | (--N)        | N: copy of R-TOS, then decrement it |
200 | | r>        | (--N)        | Pop N from the return stack |
201 | | rdrop     | (--)         | Drop R-TOS |
202 | | >t        | (N--)        | Push N onto the T stack |
203 | | t!        | (N--)        | Set T-TOS to N |
204 | | t@        | (--N)        | N: copy of T-TOS |
205 | | t@+       | (--N)        | N: copy of T-TOS, then increment T-TOS |
206 | | t@-       | (--N)        | N: copy of T-TOS, then decrement T-TOS |
207 | | t>        | (--N)        | Pop N from the T stack |
208 | | tdrop     | (--)         | Drop T-TOS |
209 | | >a        | (N--)        | Push N onto the A stack |
210 | | a!        | (N--)        | Set A-TOS to N |
211 | | a@        | (--N)        | N: copy of A-TOS |
212 | | a@+       | (--N)        | N: copy of A-TOS, then increment A-TOS |
213 | | a@-       | (--N)        | N: copy of A-TOS, then decrement A-TOS |
214 | | a>        | (--N)        | Pop N from the A stack |
215 | | adrop     | (--)         | Drop A-TOS |
216 | | >b        | (N--)        | Push N onto the B stack |
217 | | b!        | (N--)        | Set B-TOS to N |
218 | | b@        | (--N)        | N: copy of B-TOS |
219 | | b@+       | (--N)        | N: copy of B-TOS, then increment B-TOS |
220 | | b@-       | (--N)        | N: copy of B-TOS, then decrement B-TOS |
221 | | b>        | (--N)        | Pop N from the B stack |
222 | | bdrop     | (--)         | Drop B-TOS |
223 | | emit      | (C--)        | Output char C |
224 | | lit,      | (N--)        | Compile a push of number N |
225 | | next-wd   | (--A L)      | L: length of the next word (A) from the input stream |
226 | |           |              | - If L=0, then A is an empty string (end of input) |
227 | | immediate | (--)         | Mark the last created word as IMMEDIATE |
228 | | inline    | (--)         | Mark the last created word as INLINE |
229 | | outer     | (S--)        | Send string S to the c4 outer interpreter |
230 | | addword   | (--)         | Add the next word to the dictionary |
231 | | timer     | (--N)        | N: Current time |
232 | | see X     | (--)         | Output the definition of word X |
233 | | ztype     | (S--)        | Print string at S (unformatted) |
234 | | ftype     | (S--)        | Print string at S (formatted) |
235 | | s-cpy     | (D S--D)     | Copy string S to D |
236 | | s-find    | (B L S--N)   | Find string L in B starting at char S. N = -1 if not found |
237 | | s-eq      | (D S--F)     | F: 1 if string S is equal to D (case sensitive) |
238 | | s-eqi     | (D S--F)     | F: 1 if string S is equal to D (NOT case sensitive) |
239 | | s-len     | (S--N)       | N: Length of string S |
240 | | z" str"   | (--)         | - COMPILE: generate code to push address of `str` (vhere) |
241 | |           | (--A)        | - RUN: A=address of `str` |
242 | |           | (--A)        | - INTERPRET: A=address of `str` (only 1 string supported) |
243 | | ." msg"   | (--)         | - COMPILE: execute `z"`, compile `ftype` |
244 | |           | (--)         | - RUN: perform `ftype` on `msg` |
245 | |           | (--)         | - INTERPRET: output `msg` using `ftype` |
246 | | find      | (--XT A)     | XT: Execution Token, A: Dict Entry address (0 0 if not found) |
247 | | loaded?   | (XT A--)     | Stops current load if A <> 0 (see `find`) |
248 | | fopen     | (NM MD--FH)  | NM: File Name, MD: Mode, FH: File Handle (0 if error/not found) |
249 | | fclose    | (FH--)       | FH: File Handle to close |
250 | | fdelete   | (NM--)       | NM: File Name to delete |
251 | | fread     | (A N FH--X)  | A: Buffer, N: Size, FH: File Handle, X: num chars read |
252 | | fwrite    | (A N FH--X)  | A: Buffer, N: Size, FH: File Handle, X: num chars written |
253 | | fgets     | (A N FH--X)  | A: Buffer, N: Size, X: num chars read (0 if EOF/Error) |
254 | | include X | (--)         | Load file named X (X: next word) |
255 | | load      | (N--)        | N: Block number to load (file named "block-NNN.fth") |
256 | | load-next | (N--)        | Close the current block and load block N next |
257 | | system    | (S--)        | PC ONLY: S: String to send to `system()` |
258 | | bye       | (--)         | PC ONLY: Exit c4 |
259 | 
260 | ## c4 default words
261 | If _SYS_LOAD_ is not defined in file c4.h, load block-000.fth.
262 | Else, load the words in function `sys_load()` in file sys-load.c.<br/>
263 | For details, or to add or change the default words, modify that function.
264 | 


--------------------------------------------------------------------------------
/block-003.fth:
--------------------------------------------------------------------------------
 1 | ( Block 3 - Strings )
 2 | 
 3 | find fill loaded?
 4 | 
 5 | p1
vhere $100 + ;   p2
p1 $100 + ;
 6 | 
 7 | fill  (dst cnt ch--)
>t swap >a for t@ c!a+ next
atdrop ;
 8 | move  (src dst n--) 
>r >t >a r> for a@ @ t@ ! a@ cell+ a! t@ cell+ t! next
atdrop ;
 9 | cmove (src dst n--) 
>r >t >a r> for c@a+ c!t+ next
atdrop ;
10 | cmove>(src dst n--) 
>r  r@ + 1- >t  r@ + 1- >a r>  for c@a- c!t- next
atdrop ;
11 | 
12 | s-trunc(dst--dst)    
0 over c! ;
13 | s-end  (str-end)     
dup s-len + ;
14 | s-cat  (dst src--dst)
over s-end swap s-cpy drop ;
15 | s-catc (dst ch--dst) 
over s-end w! ;
16 | s-catn (dst n--dst)  
<# #s #> s-cat ;
17 | s-scpy (src dst--dst)
swap s-cpy ;
18 | s-scat (src dst--dst)
swap s-cat ;
19 | s-scatc(ch dst--dst) 
swap s-catc ;
20 | s-scatn(n dst--dst)  
swap s-catn ;
21 | s-rtrim(str--str)    
>r r@ s-end 1- >t
22 | 
  begin
t@ r@ <  c@t 32 >  orif
tdrop r> exitthen
23 |    
0 c!t-again
;
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-004.fth:
--------------------------------------------------------------------------------
 1 | ( Block 4: case / case! / end-cases / switch  )
 2 | 
 3 | ( NOTE: you can't use z" or ." when using 'case!' )
 4 | ( Any case for #0 has to be the 1st case in the table )
 5 | 
 6 | find switch loaded?
 7 | 
 8 | case ( N-- )
v, find drop v, ;
 9 | case!( N-- )
v, here v, 1 state wc! ;
10 | end-cases
0 v, 0 v, ;
11 | switch( N TBL-- )
>t >abegin
12 | 
      a@ t@ @ =if
t@ cell+ @ >r atdrop exitthen
13 | 
      t@ 2 cells + t!
14 | 
      t@ @if0
atdrop exitthen
15 | 
  again
;
16 | 
17 | ( Example usage ... )
18 | find switch loaded?( keep the example from being loaded )
19 | 
20 | case-a
." (case a)" ;
21 | case-b
." (case b)" ;
22 | 
23 | vhere const cases
24 |  'a' case    case-a
25 |  'b' case!  
123 . case-a space case-b 789 . ;
26 | end-cases
27 | 
28 | 'a' cases switch cr
29 | 'b' cases switch cr
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-005.fth:
--------------------------------------------------------------------------------
 1 | ( Block 5 - Screen )
 2 | 
 3 | find cls loaded?
 4 | 
 5 | cur-on   (--)     
." %e[?25h" ;
 6 | cur-off  (--)     
." %e[?25l" ;
 7 | cur-block(--)     
." %e[2 q" ;
 8 | cur-bar  (--)     
." %e[5 q" ;
 9 | ->cr     (r c--)  
." %e[%d;%dH" ;
10 | ->rc     (c r--)  
swap ->cr ;
11 | cls      (--)     
." %e[2J" 1 dup ->rc ;
12 | clr-eol  (--)     
." %e[0K" ;
13 | color    (bg fg--)
." %e[%d;%dm" ;
14 | fg       (fg--)   
." %e[38;5;%dm" ;
15 | 
16 | white 
255 fg ;    red   
203 fg ;
17 | green 
 40 fg ;    yellow
226 fg ;
18 | blue  
 63 fg ;    purple
201 fg ;
19 | cyan  
117 fg ;    grey  
250 fg ;
20 | 
21 | colors(f t--)
over - 1+ for
22 |     dup i + dup fg ." (color-%d)" i 10 modif0
crthen
23 |  
next drop white ;
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-006.fth:
--------------------------------------------------------------------------------
 1 | ( Block 6 - Some utility words )
 2 | 
 3 | find dump loaded?
 4 | 
 5 | .nw(num width--)
>r <# r> 1- for # next #s #> ztype ;
 6 | .2
2 .nw ;  .3
3 .nw ;  .4
4 .nw ;  .8
8 .nw ;
 7 | .NWB(num width base--)
base@ >t base! .nw t> base! ;
 8 | .hex(num--)
#2 #16 .NWB ;  .hex4 (num--)
#4 #16 .NWB ;  .hex8(num--)
#8 #16 .NWB ;
 9 | .bin(num--)
#8  #2 .NWB ;  .bin16(num--)
#16 #2 .NWB ;
10 | spaces(n--)
for space next ;
11 | a-emit(ch--)
dup 32 < over 126 > orif
drop '.'then
emit ;
12 | a-dump(addr--)
$10 for dup c@ a-emit 1+ next drop ;
13 | dump(addr num--)
swap >a 0 >t
14 | 
  for t@+if0
a@ cr .hex8 ':' emit spacethen
c@a+ .hex space
15 | 
      t@ $10 =if
3 spaces 0 t! a@ $10 - a-dumpthen
16 | 
  next atdrop ;
17 | lshift(n count--n')
for 2* next ;
18 | rshift(n count--n')
for 2/ next ;
19 | align(a--a')
4 over 3 and - 3 and + ;
20 | */(n a b--n')
>t * t> / ; Used for scaling a number
21 | 
22 | The 13/17/5 XOR shift pseudo-random number generator
23 | val seed   (val) (t0)
24 | seed!(n--)
(t0) ! ;  timer seed!
25 | rand(--n)
seed dup $1000 * xor dup $10000 / xor dup $20 * xor dup seed! ;
26 | rand-mod(max--n)
rand abs swap mod ;
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-007.fth:
--------------------------------------------------------------------------------
 1 | ( Block 7 - Registers )
 2 | 
 3 | find s9 loaded?
 4 | 
 5 | val r0   (val) t0  s0
t0 ! ;
 6 | val r1   (val) t0  s1
t0 ! ;
 7 | val r2   (val) t0  s2
t0 ! ;
 8 | val r3   (val) t0  s3
t0 ! ;
 9 | val r4   (val) t0  s4
t0 ! ;
10 | val r5   (val) t0  s5
t0 ! ;
11 | val r6   (val) t0  s6
t0 ! ;
12 | val r7   (val) t0  s7
t0 ! ;
13 | val r8   (val) t0  s8
t0 ! ;
14 | val r9   (val) t0  s9
t0 ! ;
15 | 
16 | 
17 | 
18 | 
19 | 
20 | 
21 | 
22 | 
23 | 
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-008.fth:
--------------------------------------------------------------------------------
 1 | Encode and decode TEXT in a bitmap (*.BMP) file
 2 | 
 3 | Usage: to encode:  z" bmp-file" ->bmp  z" txt-file" ->txt   encode
 4 |        to decode:  z" bmp-file" ->bmp  z" txt-file" ->file  decode  ->stdout
 5 | 
 6 | 64 var txt-fn  cell var txt-sz max-txt
  40 1024 * ; max-txt var txt
 7 | 64 var bmp-fn  cell var bmp-sz max-bmp
1024 1024 * ; max-bmp var bmp
 8 | 
 9 | NOTES: t is txt addr, a is the txt byte, b is the next bitmap byte
10 | ->txt(fn--)
txt-fn s-scpy drop ;
11 | ->bmp(fn--)
bmp-fn s-scpy drop ;
12 | read-file(addr max fn--sz)
fopen-rb ?dupif0
2drop 0 exitthen

13 |     >a  a@ fread  a> fclose ;
14 | write-file(addr sz fn--)
fopen-wb ?dupif0
2drop exitthen

15 |     >a  a@ fwrite drop  a> fclose ;
16 | skip-hdr(bmp--addr)
dup $0a + d@ + ;
17 | read-txt(--)
txt max-txt txt-fn read-file txt-sz ! ;
18 | read-bmp(--)
bmp max-bmp bmp-fn read-file bmp-sz ! ;
19 | write-txt(--)
txt txt-sz @ txt-fn write-file
;
20 | write-bmp(--)
bmp bmp-sz @ bmp-fn write-file ;
21 | encode-1(--)
a@ 2 /mod a!  c@b $FE and + c!b+ ;
22 | encode-8(b--)
a! 8 for encode-1 next ;
23 | do-encode(--)
bmp skip-hdr b!  txt t!  txt-sz @ for c@t+ encode-8 next  0 encode-8 ;
24 | decode-1(--)
8 for c@b+ 1 and >t next  0 a! 8 for a@ 2* t> + a! next ;
25 | decode-all(--)
decode-1 a@if
a@ emit decode-all exitthen
;
26 | do-decode(--)
bmp skip-hdr b! decode-all ;
27 | .files(--)
txt-sz @ txt-fn bmp-sz @ bmp-fn ." bmp: %s (%d)%ntxt: %s (%d)%n" ;
28 | init(--)
txt max-txt 0 fill  bmp max-bmp 0 fill ;
29 | encode(--)
init read-txt read-bmp .files do-encode write-bmp ;
30 | decode(--)
init read-bmp do-decode
;
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-010.fth:
--------------------------------------------------------------------------------
 1 | ( Block 10 - Variables x/y )
 2 | 
 3 | find x! loaded?
 4 | 
 5 | val x@   (val) t0   x! 
t0 ! ;
 6 | x+ 
x@ 1+ x! ;      x- 
x@ 1- x! ;
 7 | x@+
x@ dup 1+ x! ;  x@-
x@ dup 1- x! ;
 8 | !x 
x@ c! ;         @x 
x@ c@ ;
 9 | !x+
x+ c! ;         !x-
x@- c! ;
10 | x>t
x@ >t ;         t>x
t> x! ;
11 | 
12 | val y@   (val) t0   y! 
t0 ! ;
13 | y+ 
y@ 1+ y! ;      y- 
y@ 1- y! ;
14 | y@+
y@ dup 1+ y! ;  y@-
y@ dup 1- y! ;
15 | !y 
y@ c! ;         @y 
y@ c@ ;
16 | !y+
y@+ c! ;        !y-
y@- c! ;
17 | y>t
y@ >t ;         t>y
t> y! ;
18 | 
19 | 
20 | 
21 | 
22 | 
23 | 
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-020.fth:
--------------------------------------------------------------------------------
 1 | (Blocks 20:26 - A simple block editor)
 2 | 
 3 |  3 load(strings)
 4 |  4 load(case/switch)
 5 |  5 load(screen)
 6 | 10 load(vars)
 7 | 
 8 | 32 const rows            100 const cols          rows cols * const block-sz
 9 | block-sz var block       block-sz var work
10 | rows 1- const max-row    cols 1- const max-col
11 | 
12 | blk     
40 wc@ ;    >blk         
40 wc! ;
13 | row     
43 wc@ ;    >row         
43 wc! ;   row++
row 1+ >row ;
14 | col     
44 wc@ ;    >col         
44 wc! ;   col++
col 1+ >col ;
15 | ed-mode 
45 wc@ ;    >ed-mode     
45 wc! ;
16 | show?   
46 wc@ ;    show!      
1 46 wc! ;   shown  
0 46 wc! ;
17 | dirty?  
47 wc@ ;    dirty
show! 1 47 wc! ;   clean  
0 47 wc! ;
18 | >row/col(r c--)
>col >row ;
19 | >pos(r c--a)
swap cols * + block + ;
20 | rc>pos(--a)
row col >pos ;
21 | nt-line(r--) 
0 swap max-col >pos c! ;
22 | nt-lines
rows for i nt-line next ;
23 | ->cur  
col 2+ row 2+ ->cr cur-on ;
24 | ->foot 
1 rows 3 + ->cr ;
25 | ->cmd  
->foot cr clr-eol ;
26 | norm-row(x--) 
row + 0 max max-row    min >row ;
27 | norm-col(x--) 
col + 0 max max-col 1- min >col ;
28 | mv     (r c--)
norm-col norm-row row nt-line ;
29 | mv-lt
0 0 1- mv ;  mv-rt
0 1 mv ;  mv-up
0 1- 0 mv ;  mv-dn
1 0 mv ;
30 | mv-home
0 >col ;   mv-home!
 0 0 >row/col ;
31 | 
32 | 21 26 thru
33 | 


--------------------------------------------------------------------------------
/block-021.fth:
--------------------------------------------------------------------------------
 1 | block-fn( --fn )
p2 z" block-" s-cpy blk <# # # #s #> s-cat z" .fth" s-cat ;
 2 | t1( ch-- )
dup 10 =if
drop row++ 0 >col rc>pos t! exitthen
dup 4 >if
32 maxthen
c!t+ ;
 3 | t2
atdrop nt-lines ;
 4 | work->block
work >a  block >t  0 dup >row/col
 5 | 
   begin  c@a+ ?dupif0
t2 exitthen
t1 row rows < while t2 ;
 6 | clear-block( addr-- )
block-sz 32 fill ;
 7 | rl( reload block )
work clear-block  block clear-block
 8 | 
   block-fn fopen-rb ?dupif
 9 | 
       >t work block-sz t@ fread drop t> fclose
10 | 
  then
work->block clean show! 0 dup >row/col ;
11 | ed!( blk-- )
>blk rl ;
12 | normal-mode 
0 ;   insert-mode 
1 ;    replace-mode 
2 ;   quit-mode
99 ;
13 | normal-mode? 
normal-mode  ed-mode = ;  normal-mode! 
normal-mode  >ed-mode ;
14 | insert-mode? 
insert-mode  ed-mode = ;  insert-mode! 
insert-mode  >ed-mode ;
15 | replace-mode?
replace-mode ed-mode = ;  replace-mode!
replace-mode >ed-mode ;
16 | quit?        
quit-mode    ed-mode = ;  q!           
quit-mode    >ed-mode ;
17 | .mode
space normal-mode?if
." -normal-" exitthen
18 | 
   red insert-mode?if
." -insert-"then
19 | 
   replace-mode?if
." -replace-"then
20 | 
   white ;
21 | insert-toggle
22 | 
   normal-mode?if
insert-mode!  exitthen
23 | 
   insert-mode?if
replace-mode! exitthen
24 | 
   normal-mode! ;
25 | ks( -- )
yellow ." %n(press a key ...)" white key drop cls show! ;
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-022.fth:
--------------------------------------------------------------------------------
 1 | printable?( ch--ch 1 | 0 )
dup 32 126 btwiif
1 else drop 0then
;
 2 | put-char( ch-- )
rc>pos c! dirty mv-rt show! ;
 3 | replace-char( ch-- )
printable? if put-char then ;
 4 | replace-one ( -- )  
cur-off red '?' emit key white replace-char ;
 5 | insert-char ( ch-- )
printable?if0
exitthen
 6 | 
  >a rc>pos >r  row max-col >pos >t
 7 | 
 begin
t@ 1- c@  c!t-  t@ r@ >while
 8 | 
  a> r> c! tdrop mv-rt dirty ;
 9 | delete-char( -- )
rc>pos >t  row max-col >pos >r
10 | 
 begin
t@ 1+ c@  c!t+  t@ r@ <while
11 | 
  32 r> 1- c! dirty tdrop ;
12 | delete-prev
mv-lt delete-char ;
13 | eol-offset( row--offset )
>t max-col >a
14 | 
 begin
t@ a@ >pos c@ 32 >if
a@ 1+ atdrop exitthen
a@-while
0 atdrop ;
15 | mv-end( -- )
row eol-offset >col ;
16 | clear-line( r-- )
0 >pos max-col for 32 over c! 1+ next 0 swap c! dirty ;
17 | clear-eol ( r c-- )
max-col over - >t >pos t> for 32 over c! 1+ next drop dirty ;
18 | insert-line( -- ) 
row max-row <if
19 | 
     row 0 >pos >t  t@  t@ cols +  max-row 0 >pos t> - cmove>
20 | 
 then
 row clear-line  dirty ;
21 | delete-line( -- ) 
row max-row <if
22 | 
     row 0 >pos >t  t@ cols + >r  rows 0 >pos r@ - >a  r> t> a> cmove
23 | 
 then
 max-row clear-line  dirty ;
24 | insert-row( r-- )
row swap  >row insert-line  >row ;
25 | delete-row( r-- )
row swap  >row delete-line  >row ;
26 | join-lines( -- )
row max-row >=if
exitthen
27 | 
  p1 row 0 >pos s-cpy s-rtrim 32 s-catc
28 | 
  row 1+ 0 >pos s-cat cols 1- + 0 swap c!
29 | 
  row 0 >pos p1 s-cpy drop
30 | 
  row 1+ delete-row ;
31 | open-line( flg-- )if
mv-dnthen
insert-line insert-mode! mv-home ;
32 | 
33 | 


--------------------------------------------------------------------------------
/block-023.fth:
--------------------------------------------------------------------------------
 1 | #256  #71 or const key-home ( 27 91 72 )
 2 | #256  #72 or const key-up   ( 27 91 65 )
 3 | #256  #73 or const key-pgup ( 27 91 53 126 )
 4 | #256  #75 or const key-left ( 27 91 68 )
 5 | #256  #77 or const key-right( 27 91 67 )
 6 | #256  #79 or const key-end  ( 27 91 70 )
 7 | #256  #80 or const key-down ( 27 91 66 )
 8 | #256  #81 or const key-pgdn ( 27 91 54 126 )
 9 | #256  #82 or const key-ins  ( 27 91 50 126 )
10 | #256  #83 or const key-del  ( 27 91 51 126 )
11 | #256 #119 or const key-chome( 27 91 49 59 53 72 )
12 | #256 #117 or const key-cend ( 27 91 49 59 53 70 )
13 | 
14 | win-key( --k )
key #256 or ;
15 | vk2( --k )
key 126 <>if
27 exitthen
16 | 
   a@ 50 =if
key-ins   exitthen
17 | 
   a@ 51 =if
key-del   exitthen
18 | 
   a@ 53 =if
key-pgup  exitthen
19 | 
   a@ 54 =if
key-pgdn  exitthen  
27 ;
20 | vk1( --k )
key a!
21 | 
   a@ 65 =if
key-up    exitthen
22 | 
   a@ 66 =if
key-down  exitthen
23 | 
   a@ 67 =if
key-right exitthen
24 | 
   a@ 68 =if
key-left  exitthen
25 | 
   a@ 70 =if
key-end   exitthen
26 | 
   a@ 72 =if
key-home  exitthen
27 | 
   a@ 50 55 btwiif
vk2 exitthen  
27 ;
28 | vt-key( --k )
key 91 =if
vk1 exitthen
27 ;
29 | vkey( --k )
key
30 | 
   dup 224 =if
drop win-key exitthen
31 | 
   dup  27 =if
drop vt-key  exitthen
;
32 | 
33 | 


--------------------------------------------------------------------------------
/block-024.fth:
--------------------------------------------------------------------------------
 1 | cols var cmd-buf cols var yank-buf
 2 | ->file(fh--)
(output-fp) ! ;  ->stdout
0 ->file ;
 3 | write-row 
p1 i 0 >pos s-cpy s-rtrim ztype 10 emit ;
 4 | write-block
rows for write-row next ;
 5 | w(write the block)
dirty?if
block-fn fopen-wb ?dup
 6 |    if
>t t@ ->file write-block t> fclose clean ->stdoutthen then
;
 7 | bs
8 emit ;
 8 | del-ch( -- )
y@ x@ <if
x- 0 !x bs space bsthen
;
 9 | app-ch( ch-- )
!x+ 0 !x emit ;
10 | clr-buf
y@ x! 0 !x ;
11 | t5
0 >a x>t y>t ;  t4
t>y t>x adrop ;
12 | accept( str-- )
t5 y! clr-buf
13 |  begin
key a!
14 | 
   a@ 13 = if
t4 exitthen
15 | 
   a@ 27 =  a@ 3 =    or if
clr-buf t4 exitthen
16 | 
   a@ 8 =   a@ 127 =  or if
del-chthen
17 | 
   a@ printable?if
a@ app-chthen
18 | 
again
;
19 | q(quit)
dirty?if
." (use q! to quit without saving)" exitthen
q! ;
20 | wq(write and quit)
w q! ;
21 | ed-exec(A--)
->cmd 3 state wc! outer ;
22 | do-cmd    
->cmd ':' emit cur-on cmd-buf accept cmd-buf ed-exec ;
23 | yank-line 
yank-buf row 0 >pos  s-cpy drop ;
24 | put-line  
insert-line  row 0 >pos yank-buf s-cpy drop dirty ;
25 | next-blk  
w blk 1- 0 max ed! ;   prev-blk 
w blk 1+ ed! ;
26 | mv-tab-l  
0 -8 mv ;              mv-tab-r 
0 8 mv ;
27 | mv-cr     
1 -99 mv ;             mv-end!  
max-row 0 >row/col ;
28 | yank/del  
yank-line delete-line ;
29 | exec-line 
row 0 >pos ed-exec ;
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-025.fth:
--------------------------------------------------------------------------------
 1 | vhere const ctrl-cases
 2 |   key-up   case  mv-up           key-down  case  mv-dn          127 case  mv-lt
 3 |   key-left case  mv-lt           key-right case  mv-rt          8   case  mv-lt
 4 |   key-end  case  mv-end          key-cend  case  mv-end!        9   case  mv-tab-r
 5 |   key-home case  mv-home         key-chome case  mv-home!       17  case  mv-tab-l
 6 |   key-pgup case  next-blk        key-pgdn  case  prev-blk       13  case  mv-cr
 7 |   key-ins  case  insert-toggle   key-del   case  delete-char    24  case  delete-prev
 8 |   5 case   exec-line            19        case  w             27  case  normal-mode!
 9 |   1 case!
1 put-char ;  2 case!
2 put-char ;  3 case!
3 put-char ;  4 case!
4 put-char ;
10 | end-cases
11 | 
12 | vhere const ed-cases
13 |   'k' case  mv-up          'h' case  mv-lt    'j' case mv-dn     'l' case  mv-rt
14 |   32  case  mv-rt          '_' case  mv-home  'q' case mv-tab-r  'Q' case  mv-tab-l
15 |   'R' case  replace-mode!  'r' case  replace-one                 '$' case  mv-end
16 |   'i' case  insert-mode!   'b' case!
32 insert-char mv-lt ;
17 |   ':' case  do-cmd         '!' case!
cmd-buf ed-exec ;    'D' case  yank/del
18 |   'x' case  delete-char    'X' case  delete-prev
19 |   'J' case  join-lines     'Y' case  yank-line          'E' case  exec-line
20 |   'p' case  put-line       'P' case!
mv-dn put-line ;  'A' case!
mv-end insert-mode! ;
21 |   '-' case  next-blk       '+' case  prev-blk           'C' case!
row col clear-eol ;
22 |   'o' case!
1 open-line ; 'O' case!
0 open-line ;     '#' case!
cur-block cls show! ;
23 |   '1' case!
1 put-char ;  '2' case!
2 put-char ;
24 |   '3' case!
3 put-char ;  '4' case!
4 put-char ;
25 | end-cases
26 | 
27 | :ed-key( ch-- )
dup 32 126 btwiif0
ctrl-cases switch exitthen
28 | 
   insert-mode? if
insert-char  exitthen
29 | 
   replace-mode?if
replace-char exitthen
30 | 
   ed-cases switch ;
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-026.fth:
--------------------------------------------------------------------------------
 1 | ( Editor main loop )
 2 | 
 3 | ( ANSI colors ...        COMPILE  DEFINE   INTERPRET  COMMENT )
 4 |  vhere const ed-colors   40 vc,   203 vc,  226 vc,    255 vc,
 5 | 
 6 | ed-col@(state--color)-if
1- ed-colors + c@then
;
 7 | ed-col!(color state--)
1- ed-colors + c! ;
 8 | t1(--)
green cols 1+ for '-' emit next cr ;
 9 | t2(--)
green '|' emit ;
10 | footer(--)
white ->foot blk ."  -Block %d- "
11 | 
   bl dirty?if
drop '*'then
emit
12 | 
   col 1+ row 1+ ."  (%d,%d) " .mode rc>pos c@ ."  (%d)"
13 | 
   cmd-buf ."   (cmd: %S)" clr-eol ;
14 | ed-emit(ch--)
dup 5 <if
dup ed-col@ fgthen
32 max emit ;
15 | ed-type(a--)
white >a cols 1- for c@a+ ed-emit next adrop ;
16 | show (--)
cur-off 1 1 ->rc t1 rows for t2 i 0 >pos ed-type t2 cr next t1 shown ;
17 | ?show(--)
show?if
showthen
footer ;
18 | ed-init(--)
0 dup >row/col normal-mode! clean cur-block ;
19 | ed-loop(--)begin
?show ->cur vkey cur-off ed-key quit?until
->cmd cur-on ;
20 | ed(--)
ed-init rl cls ed-loop ;
21 | edit(blk--)
>blk ed ;
22 | 
23 | 
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-049.fth:
--------------------------------------------------------------------------------
 1 | ( Block 49 )
 2 | 
 3 | 50 load
 4 | 
 5 | cell var cp
 6 | 
 7 | rl
forget 49 load ;
 8 | 
 9 | ?sp
c@
32 >if
spacethen
;
10 | ((
1 33 wc! a@ 1+ c@ '(' =if
a+then
'(' emit a@ ?sp ;
11 | ))
0 33 wc! ." ) "
;
12 | cm?
33 wc@ ;
13 | ?cm
cm?if
))then
;
14 | .\
'\' emit ;
15 | cc(t)
space t@ 10 =if
?cm .\ cr exitthen
space
16 |   
t@ 2 =if
?cm ." : "then
17 |   
t@ 1 =if
?cmthen
18 |   
t@ 3 =if
?cmthen
19 |   
t@ 4 =if
((then
20 |   
;
21 | .qt? (c--)
dup '\' =if
.\then
;
22 | .bsl?(c--)
dup '"' =if
.\then
;
23 | .ch  (c-- )
.qt? .bsl? emit ;
24 | wk   (c--)
>t t@ 31 >if
t> .ch exitthen
cc tdrop ;
25 | lp   (--)
c@a-if
wk a+ lp exitthen
drop ;
26 | ini  (blk--)
blk-buf a! ;
27 | doit (blk--)
ini lp ;
28 | go(--)
num-blocks for i doit next ;
29 | 
30 | cr cr 49 ini lp
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-050.fth:
--------------------------------------------------------------------------------
 1 | ( Block 50 - Blocks )
 2 | 
 3 | find blocks loaded?
 4 | 
 5 | 3 load(strings)
 6 | 
 7 | 341 blocks of 3k is close to 1 meg
 8 | block-sz  
3072 ;inline
 9 | num-blocks 
341 ;inline
10 | 
11 | block-sz num-blocks * var blocks
12 | num-blocks var fl(clean/dirty flags)
13 | 
14 | blk-norm(n--blk)
0 maxnum-blocks 1- lit,
min ;
15 | blk-flg! (blk flg--)
swap blk-norm fl + c! ;
16 | blk-dirty!(blk--)
1 blk-flg! ;
17 | blk-clean!(blk--)
0 blk-flg! ;
18 | blk-dirty?(blk--flg)
blk-norm fl + c@ ;
19 | blk-buf(blk--buf)
blk-norm block-sz * blocks + ;
20 | 
21 | 32 var fn(file-name)
22 | blk-fn(blk--fn)
>r fn z" block-" s-cpy r>
23 |     <# # # #s #> s-cat z" .fth" s-cat ;
24 | 
25 | blk-clear(blk--)
dup blk-clean! blk-buf block-sz 0 fill ;
26 | blk-clear-all(--)
num-blocks for i blk-clear next ;
27 | 
28 | 51 load-next
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-051.fth:
--------------------------------------------------------------------------------
 1 | ( Block 51 - More Blocks )
 2 | 
 3 | find blk-init loaded?
 4 | 
 5 | blk-read(blk--)
blk-norm >t t@ blk-fn fopen-rb
 6 |    
?dupif0
t> blk-clear exitthen( fn ." %n-r/%S-" )
 7 |    
>a t> blk-buf block-sz a@ fread drop a> fclose ;
 8 | blk-read-all(--)
num-blocks for i blk-read next ;
 9 | 
10 | blk-write(blk--)
blk-norm >a a@ blk-dirty?if0
adrop exitthen
11 |    
a@ blk-buf >t a@ blk-fn fopen-wb ?dup fn ." %n-w/%S-"
12 |    if
>r t@ block-sz r@ fwrite . r> fclosethen
atdrop ;
13 | blk-flush(--)
num-blocks for i blk-write next ;
14 | 
15 | blk-rm(blk--)
dup blk-fn fdelete blk-clear ;
16 | blk-cp-buf(buf blk--)
dup blk-dirty! blk-buf block-sz cmove ;
17 | blk-cp(from to--)
>t blk-buf t> blk-cp-buf blk-flush ;
18 | blk-mv(from to--)
over swap blk-cp blk-rm blk-flush ;
19 | blk-ins(n to--)
1+ >t >a
20 |    begin
t@- t@ swap blk-mv t@ a@ >while
tdrop a> blk-rm blk-flush ;
21 | 
22 | blk-load(blk--)
blk-buf outer ;
23 | blk-init(--)
blk-clear-all blk-read-all ;
24 | 
25 | blk-init
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-200.fth:
--------------------------------------------------------------------------------
 1 | ( benchmarks / tests )
 2 | 
 3 | find bm1 loaded?
 4 | test-if
'n' swapif
drop 'y'then
emit '.' emit ;
 5 | if-elseif
z" yes" else z" no"then
ztype '.' emit ;
 6 | cr 0 test-if 1 test-if    see test-if cr
 7 |  cr 0 if-else 1 if-else    see if-else cr
 8 | ..
dup . ;
 9 | [[
cr 5 for i . ." -- " 4 for i . next ." -- " next]]
10 | [[
cr 10 begin .. 1- dup      while drop]]
11 | [[
cr  0 begin .. 1+ dup 10 = until drop]]
12 | elapsed
timer swap - ."  (%d usec)" ;   mil
1000 dup * * ;
13 | t0
1 drop ;                             t1
1 drop t0 ;
14 | fib
1- dup 2 < if drop 1 exit then dup fib swap 1- fib + ;
15 | bm1
cr dup ." bm1: empty loop: (%d)"     timer swap for next elapsed ;
16 | bm2
cr dup ." bm2: decrement loop: (%d)" timer swap begin 1- -while drop elapsed ;
17 | bm3
cr dup ." bm3: call loop: (%d)"      timer swap for t0 next elapsed ;
18 | bm4
cr dup ." bm4: 2 call loop: (%d)"    timer swap for t1 next elapsed ;
19 | bm5
cr dup ." bm5: fib (%d) ... " timer swap fib . elapsed ;
20 | bmk
1000 mil bm1 ;
21 | go
 250 mil dup dup bmk bm2 bm3 bm4  38 bm5 cr ;
22 | go
23 |  val xxx (val) (xxx) 1234 (xxx) !
24 | see xxx cr cr
25 |  xxx ." -xxx created, (%d)-%n"
26 |  xxx const yyy
27 |  yyy ." -yyy created, (%d)-" cr
28 |  see yyy cr
29 | [[
xxx yyy = ." val/const: "if
." PASS" exitthen
." FAIL!"]]
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-201.fth:
--------------------------------------------------------------------------------
 1 | ( Mandelbrot set )
 2 | 
 3 | 7 load( registers )
 4 | 
 5 | val k    (val) t0  k!
t0 ! ;
 6 | val x    (val) t0  x!
t0 ! ;
 7 | val y    (val) t0  y!
t0 ! ;
 8 | val z    (val) t0  z!
t0 ! ;
 9 | 
10 | sqr/ 
dup * z / ; inline
11 | calc 
r1 sqr/ s3  r2 sqr/ s4
12 |    r3 r4 + k >if
1 exitthen

13 |    r1 r2 * 100 / y + s2
14 |    r3 r4 - x + s1
15 |    r5 1+ s5  r5 z > ;
16 | 
17 | l-loop 
0 s1 0 s2 0 s5begin
calcuntil
;
18 | m-loop 
l-loop r5 40 + dup '~' >if
drop blthen
emit ;
19 | x-loop 
-490 x! 95 for m-loop x  8 + x! next cr ;
20 | y-loop 
-340 y! 35 for x-loop y 20 + y! next ;
21 | mbrot  
cls ." The Mandelbrot set%n" 1000000 k!  200 z!  y-loop ;
22 | 
23 | 
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/block-202.fth:
--------------------------------------------------------------------------------
 1 | ( Conway's Game Of Life )
 2 | 
 3 | rows(--n)
75 ;  cols(--n)
150 ;
 4 | grid-sz rows cols *     const grid-sz
 5 | grid    grid-sz         var   grid
 6 | work    grid-sz         var   work
 7 | start   grid cols + 1+  const start
 8 | end     work cols - 2 - const end
 9 | states  10              var   states     states z"   ?*      " s-cpy drop
10 | nb(addr--addr+1)
dup c@ 1+ over c! 1+ ;
11 | neighbors(addr--)
cols - 1- nb nb nb cols + 3 - nb 1+ nb cols + 3 - nb nb nb drop ;

12 | ?alive(--)
c@a '*' =if
a@ grid - work + neighborsthen
;
13 | live?(--c)
c@b states + c@ dup '?' =if
drop c@athen
;
14 | prep(a--a1 c)
100 + >t t@ c@t 0 c!t tdrop ;
15 | .row(r--)
cols * grid + 10 + dup prep >t >t ztype t> t> swap c! ;
16 | disp(--)
1 1 ->cr  35 for  i 10 + .row cr  next ;
17 | grid->work(--)
start a!begin 
?alive  a@+ end < while
;
18 | work->grid(--)
work b! grid a!  grid-sz for  live? c!a+  0 c!b+ next ;

19 | one-gen(--)
grid->work work->grid disp ;
20 | gens(gens--)
for one-gen  ?keyif
key drop unloop exitthen
next ;
21 | init(--)
grid a!  grid-sz for  100 rand-mod 70 > 10 * 32 + c!a+  next ;32+10=42 ('*')
22 | life(gens--)
cur-off dupif0
drop 500then
cls init gens cur-on ;
23 | lifes(n--)
for 1000 life.s key drop
next ;
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/c4.c:
--------------------------------------------------------------------------------
  1 | #include "c4.h"
  2 | 
  3 | #define NCASE         goto next; case
  4 | #define BCASE         break; case
  5 | #define dsp           code[DSPA]
  6 | #define rsp           code[RSPA]
  7 | #define lsp           code[LSPA]
  8 | #define tsp           code[TSPA]
  9 | #define asp           code[ASPA]
 10 | #define bsp           code[BSPA]
 11 | #define here          code[HA]
 12 | #define base          code[BA]
 13 | #define state         code[SA]
 14 | #define TOS           dstk[dsp]
 15 | #define NOS           dstk[dsp-1]
 16 | #define L0            lstk[lsp]
 17 | #define L1            lstk[lsp-1]
 18 | #define L2            lstk[lsp-2]
 19 | 
 20 | byte memory[MEM_SZ+1];
 21 | wc_t *code = (wc_t*)&memory[0];
 22 | cell dstk[STK_SZ+1], rstk[STK_SZ+1], lstk[LSTK_SZ+1];
 23 | cell tstk[TSTK_SZ+1], astk[TSTK_SZ+1], bstk[TSTK_SZ+1], vhere;
 24 | char wd[32], *toIn;
 25 | DE_T tmpWords[10], *last;
 26 | 
 27 | #define PRIMS_BASE \
 28 | 	X(EXIT,    "exit",      0, if (0<rsp) { pc = (wc_t)rpop(); } else { return; } ) \
 29 | 	X(DUP,     "dup",       0, t=TOS; push(t); ) \
 30 | 	X(SWAP,    "swap",      0, t=TOS; TOS=NOS; NOS=t; ) \
 31 | 	X(DROP,    "drop",      0, pop(); ) \
 32 | 	X(OVER,    "over",      0, t=NOS; push(t); ) \
 33 | 	X(FET,     "@",         0, TOS = fetchCell(TOS); ) \
 34 | 	X(FET8,    "c@",        0, TOS = *(byte *)TOS; ) \
 35 | 	X(FET16,   "w@",        0, TOS = fetch16(TOS); ) \
 36 | 	X(FET32,   "d@",        0, TOS = fetch32(TOS); ) \
 37 | 	X(FETWC,   "wc@",       0, TOS = code[(wc_t)TOS]; ) \
 38 | 	X(STO,     "!",         0, t=pop(); n=pop(); storeCell(t, n); ) \
 39 | 	X(STO8,    "c!",        0, t=pop(); n=pop(); *(byte*)t=(byte)n; ) \
 40 | 	X(STO16,   "w!",        0, t=pop(); n=pop(); store16(t, n); ) \
 41 | 	X(STO32,   "d!",        0, t=pop(); n=pop(); store32(t, n); ) \
 42 | 	X(STOWC,   "wc!",       0, t=pop(); n=pop(); code[(wc_t)t] = (wc_t)n; ) \
 43 | 	X(ADD,     "+",         0, t=pop(); TOS += t; ) \
 44 | 	X(SUB,     "-",         0, t=pop(); TOS -= t; ) \
 45 | 	X(MUL,     "*",         0, t=pop(); TOS *= t; ) \
 46 | 	X(DIV,     "/",         0, t=pop(); TOS /= t; ) \
 47 | 	X(SLMOD,   "/mod",      0, t=TOS; n = NOS; TOS = n/t; NOS = n%t; ) \
 48 | 	X(INCR,    "1+",        0, ++TOS; ) \
 49 | 	X(DECR,    "1-",        0, --TOS; ) \
 50 | 	X(PLSTO,   "+!",        0, t=pop(); n=pop(); storeCell(t, n+fetchCell(t)); ) \
 51 | 	X(LT,      "<",         0, t=pop(); TOS = (TOS < t); ) \
 52 | 	X(EQ,      "=",         0, t=pop(); TOS = (TOS == t); ) \
 53 | 	X(GT,      ">",         0, t=pop(); TOS = (TOS > t); ) \
 54 | 	X(EQ0,     "0=",        0, TOS = (TOS == 0) ? 1 : 0; ) \
 55 | 	X(AND,     "and",       0, t=pop(); TOS &= t; ) \
 56 | 	X(OR,      "or",        0, t=pop(); TOS |= t; ) \
 57 | 	X(XOR,     "xor",       0, t=pop(); TOS ^= t; ) \
 58 | 	X(COM,     "com",       0, TOS = ~TOS; ) \
 59 | 	X(FOR,     "for",       0, lsp+=3; L2=pc; L0=0; L1=pop(); ) \
 60 | 	X(INDEX,   "i",         0, push(L0); ) \
 61 | 	X(NEXT,    "next",      0, if (++L0<L1) { pc=(wc_t)L2; } else { lsp=(lsp<3) ? 0 : lsp-3; } ) \
 62 | 	X(UNLOOP,  "unloop",    0, lsp = (lsp<3) ? 0 : lsp-3; ) \
 63 | 	X(TOR,     ">r",        0, rpush(pop()); ) \
 64 | 	X(RSTO,    "r!",        0, rstk[rsp] = pop(); ) \
 65 | 	X(RAT,     "r@",        0, push(rstk[rsp]); ) \
 66 | 	X(RATI,    "r@+",       0, push(rstk[rsp]++); ) \
 67 | 	X(RATD,    "r@-",       0, push(rstk[rsp]--); ) \
 68 | 	X(RFROM,   "r>",        0, push(rpop()); ) \
 69 | 	X(RDROP,   "rdrop",     0, rpop(); ) \
 70 | 	X(TTO,     ">t",        0, t=pop(); if (tsp < TSTK_SZ) { tstk[++tsp]=t; }; ) \
 71 | 	X(TSTO,    "t!",        0, tstk[tsp] = pop(); ) \
 72 | 	X(TAT,     "t@",        0, push(tstk[tsp]); ) \
 73 | 	X(TATI,    "t@+",       0, push(tstk[tsp]++); ) \
 74 | 	X(TATD,    "t@-",       0, push(tstk[tsp]--); ) \
 75 | 	X(TFROM,   "t>",        0, push((0 < tsp) ? tstk[tsp--] : 0); ) \
 76 | 	X(TDROP,   "tdrop",     0, if (0 < tsp) { tsp--; } ) \
 77 | 	X(TOA,     ">a",        0, t=pop(); if (asp < TSTK_SZ) { astk[++asp] = t; } ) \
 78 | 	X(ASET,    "a!",        0, astk[asp]=pop(); ) \
 79 | 	X(AGET,    "a@",        0, push(astk[asp]); ) \
 80 | 	X(AGETI,   "a@+",       0, push(astk[asp]++); ) \
 81 | 	X(AGETD,   "a@-",       0, push(astk[asp]--); ) \
 82 | 	X(AFROM,   "a>",        0, push((0 < asp) ? astk[asp--] : 0); ) \
 83 | 	X(ADROP,   "adrop",     0, if (0 < asp) { asp--; } ) \
 84 | 	X(TOB,     ">b",        0, t=pop(); if (bsp < TSTK_SZ) { bstk[++bsp] = t; } ) \
 85 | 	X(BSET,    "b!",        0, bstk[bsp]=pop(); ) \
 86 | 	X(BGET,    "b@",        0, push(bstk[bsp]); ) \
 87 | 	X(BGETI,   "b@+",       0, push(bstk[bsp]++); ) \
 88 | 	X(BGETD,   "b@-",       0, push(bstk[bsp]--); ) \
 89 | 	X(BFROM,   "b>",        0, push((0 < bsp) ? bstk[bsp--] : 0); ) \
 90 | 	X(BDROP,   "bdrop",     0, if (0 < bsp) { bsp--; } ) \
 91 | 	X(EMIT,    "emit",      0, emit((char)pop()); ) \
 92 | 	X(KEY,     "key",       0, push(key()); ) \
 93 | 	X(QKEY,    "?key",      0, push(qKey()); ) \
 94 | 	X(SEMI,    ";",         1, comma(EXIT); state=INTERP; ) \
 95 | 	X(LITC,    "lit,",      0, t=pop(); compileNum(t); ) \
 96 | 	X(NEXTWD,  "next-wd",   0, push((cell)wd); push(nextWord()); ) \
 97 | 	X(IMMED,   "immediate", 0, { last->fl=_IMMED; } ) \
 98 | 	X(INLINE,  "inline",    0, makeInline(); ) \
 99 | 	X(OUTER,   "outer",     0, outer((char*)pop()); ) \
100 | 	X(ADDWORD, "addword",   0, addWord(0); ) \
101 | 	X(CLK,     "timer",     0, push(timer()); ) \
102 | 	X(SEE,     "see",       0, doSee(); ) \
103 | 	X(ZTYPE,   "ztype",     0, zType((char*)pop()); ) \
104 | 	X(FTYPE,   "ftype",     0, fType((char*)pop()); ) \
105 | 	X(SCPY,    "s-cpy",     0, t=pop(); strCpy((char*)TOS, (char*)t); ) \
106 | 	X(SEQ,     "s-eq",      0, t=pop(); TOS = strEq((char*)TOS, (char*)t); ) \
107 | 	X(SEQI,    "s-eqi",     0, t=pop(); TOS = strEqI((char*)TOS, (char*)t); ) \
108 | 	X(SLEN,    "s-len",     0, TOS = strLen((char*)TOS); ) \
109 | 	X(SFIND,   "s-find",    0, t=pop(); n=pop(); TOS = strFind((char*)TOS, (char*)n, t); ) \
110 | 	X(ZQUOTE,  "z\"",       1, quote(); ) \
111 | 	X(DOTQT,   ".\"",       1, quote(); (state==COMPILE) ? comma(FTYPE) : fType((char*)pop()); ) \
112 | 	X(FIND,    "find",      0, { DE_T *dp=findWord(0); push(dp?dp->xt:0); push((cell)dp); } )
113 | 
114 | #define PRIMS_FILE \
115 | 	X(LOADED,  "loaded?",   0, t=pop(); pop(); if (t) { fileClose(inputFp); inputFp=filePop(); } ) \
116 | 	X(FLOPEN,  "fopen",     0, t=pop(); n=pop(); push(fileOpen((char*)n, (char*)t)); ) \
117 | 	X(FLCLOSE, "fclose",    0, t=pop(); fileClose(t); ) \
118 | 	X(FLDEL,   "fdelete",   0, t=pop(); fileDelete((char*)t); ) \
119 | 	X(FLREAD,  "fread",     0, t=pop(); n=pop(); TOS = fileRead((char*)TOS, (int)n, t); ) \
120 | 	X(FLWRITE, "fwrite",    0, t=pop(); n=pop(); TOS = fileWrite((char*)TOS, (int)n, t); ) \
121 | 	X(FLGETS,  "fgets",     0, t=pop(); n=pop(); TOS = fileGets((char*)TOS, (int)n, t); ) \
122 | 	X(INCL,    "include",   0, t=nextWord(); if (t) fileLoad(wd); ) \
123 | 	X(LOAD,    "load",      0, t=pop(); blockLoad((int)t); ) \
124 | 	X(NXTBLK,  "load-next", 0, t=pop(); blockLoadNext((int)t); ) \
125 | 	X(EDITBLK, "edit",      0, editBlock(pop()); )
126 | 
127 | #define PRIMS_SYSTEM \
128 | 	X(SYSTEM,  "system", 0, t=pop(); ttyMode(0); system((char*)t); ) \
129 | 	X(BYE,     "bye",    0, ttyMode(0); exit(0); )
130 | 
131 | #define X(op, name, imm, cod) op,
132 | 
133 | enum _PRIM  {
134 | 	STOP, LIT, JMP, JMPZ, NJMPZ, JMPNZ, NJMPNZ, PRIMS_BASE PRIMS_FILE PRIMS_SYSTEM
135 | };
136 | 
137 | #undef X
138 | #define X(op, name, imm, code) { name, op, imm, 0 },
139 | 
140 | PRIM_T prims[] = { PRIMS_BASE PRIMS_FILE PRIMS_SYSTEM {0, 0, 0, 0}};
141 | 
142 | void push(cell x) { if (dsp < STK_SZ) { dstk[++dsp] = x; } }
143 | cell pop() { return (0<dsp) ? dstk[dsp--] : 0; }
144 | void rpush(cell x) { if (rsp < STK_SZ) { rstk[++rsp] = x; } }
145 | cell rpop() { return (0<rsp) ? rstk[rsp--] : 0; }
146 | void store16(cell a, cell v) { *(uint16_t*)(a) = (uint16_t)v; }
147 | cell fetch16(cell a) { return *(uint16_t*)(a); }
148 | void storeWC(wc_t a, wc_t v) { code[a] = v; }
149 | wc_t fetchWC(wc_t a) { return code[a]; }
150 | void store32(cell a, cell v) { *(uint32_t*)(a) = (uint32_t)v; }
151 | cell fetch32(cell a) { return *(uint32_t*)(a); }
152 | void storeCell(cell a, cell v) { *(cell*)(a) = v; }
153 | cell fetchCell(cell a) { return *(cell*)(a); }
154 | void comma(cell x) { code[here++] = (wc_t)x; }
155 | void commaCell(cell n) { storeCell((cell)&code[here], n); here += (CELL_SZ / WC_SZ); }
156 | int changeState(int x) { state = x; return x; }
157 | void makeInline() { last->fl=_INLINE; }
158 | void ok() { if (state==0) { state=INTERP; } zType((state==INTERP) ? " ok\r\n" : "... "); }
159 | int lower(const char c) { return btwi(c, 'A', 'Z') ? c + 32 : c; }
160 | int strLen(const char *s) { int l = 0; while (s[l]) { l++; } return l; }
161 | 
162 | int strEqI(const char *s, const char *d) {
163 | 	while (lower(*s) == lower(*d)) { if (*s == 0) { return 1; } s++; d++; }
164 | 	return 0;
165 | }
166 | 
167 | int strEq(const char *s, const char *d) {
168 | 	while (*s == *d) { if (*s == 0) { return 1; } s++; d++; }
169 | 	return 0;
170 | }
171 | 
172 | void strCpy(char *d, const char *s) {
173 | 	while (*s) { *(d++) = *(s++); }
174 | 	*(d) = 0;
175 | }
176 | 
177 | int startsWith(const char *buf, const char *lookFor) {
178 |     while (*lookFor) {
179 |         if (*(lookFor++) != *(buf++)) { return 0; }
180 |     }
181 |     return 1;
182 | }
183 | 
184 | int strFind(const char *buf, const char *lookFor, int start) {
185 |     if (strLen(buf) <= start) { return -1; }
186 |     while (buf[start]) {
187 |         if (startsWith(&buf[start], lookFor)) { return start; }
188 |         ++start;
189 |     }
190 |     return -1;
191 | }
192 | 
193 | int nextWord() {
194 | 	int len = 0, ch;
195 | 	while (btwi(*toIn, 1, 32)) {
196 | 		ch = *(toIn++);
197 | 		if (btwi(ch,COMPILE,COMMENT)) { state = ch; }
198 | 	}
199 | 	while (btwi(*toIn, 33, 126)) { wd[len++] = *(toIn++); }
200 | 	wd[len] = 0;
201 | 	return len;
202 | }
203 | 
204 | int isTempWord(const char *w) {
205 | 	return ((w[0]=='t') && btwi(w[1],'0','9') && (w[2]==0)) ? 1 : 0;
206 | }
207 | 
208 | DE_T *addWord(const char *w) {
209 | 	if (!w) { nextWord(); w = wd; }
210 | 	if (NAME_LEN < strLen(wd)) { zTypeF("\n-len:%s-\n", wd); wd[NAME_LEN]=0; }
211 | 	if (isTempWord(w)) {
212 | 		tmpWords[w[1]-'0'].xt = here;
213 | 		return &tmpWords[w[1]-'0'];
214 | 	}
215 | 	int ln = strLen(w);
216 | 	--last;
217 | 	last->xt = here;
218 | 	last->fl = 0;
219 | 	last->ln = ln;
220 | 	strCpy(last->nm, w);
221 | 	// zTypeF("\n-add:%d,[%s],(%d)-\n", last, last->nm, last->xt);
222 | 	return last;
223 | }
224 | 
225 | DE_T *findWord(const char *w) {
226 | 	if (!w) { nextWord(); w = wd; }
227 | 	if (isTempWord(w)) { return &tmpWords[w[1]-'0']; }
228 | 	cell len = strLen(w);
229 | 	DE_T *dp = last;
230 | 	while ((byte*)dp < &memory[MEM_SZ]) {
231 | 		if ((len == dp->ln) && strEqI(dp->nm, w)) { return dp; }
232 | 		++dp;
233 | 	}
234 | 	return (DE_T*)0;
235 | }
236 | 
237 | cell findXT(int xt) {
238 | 	DE_T *dp = last;
239 | 	while ((byte*)dp < &memory[MEM_SZ]) {
240 | 		if (dp->xt == xt) { return (cell)dp; }
241 | 		++dp;
242 | 	}
243 | 	return 0;
244 | }
245 | 
246 | void doSee() {
247 | 	DE_T *dp = findWord(0), *lastWord = last;
248 | 	if (!dp) { zTypeF("-nf:%s-", wd); return; }
249 | 	if (dp->xt <= BYE) { zTypeF("%s is a primitive (#%ld/$%lX).\r\n", wd, dp->xt, dp->xt); return; }
250 | 	cell x = (cell)dp;
251 | 	wc_t i = dp->xt, stop = (lastWord < dp) ? (dp-1)->xt : here;
252 | 	zTypeF("\r\n%04lX: %s (%04lX to %04lX)", (long)x, dp->nm, (long)dp->xt, (long)stop-1);
253 | 	while (i < stop) {
254 | 		wc_t op = code[i++];
255 | 		zTypeF("\r\n%04X: %04X\t", i-1, op);
256 | 		if (op & NUM_BITS) { op &= NUM_MASK; zTypeF("num #%ld ($%lX)", op, op); continue; }
257 | 		x = code[i];
258 | 		switch (op) {
259 | 			case  STOP: zType("stop"); i++;
260 | 			BCASE LIT: x = fetchCell((cell)&code[i]);
261 | 				zTypeF("lit #%zd ($%zX)", (size_t)x, (size_t)x);
262 | 				i += (CELL_SZ/WC_SZ);
263 | 			BCASE JMP:    zTypeF("jmp $%04lX", (long)x);             i++;
264 | 			BCASE JMPZ:   zTypeF("jmpz $%04lX (IF)", (long)x);       i++;
265 | 			BCASE NJMPZ:  zTypeF("njmpz $%04lX (-IF)", (long)x);     i++;
266 | 			BCASE JMPNZ:  zTypeF("jmpnz $%04lX (WHILE)", (long)x);   i++;
267 | 			BCASE NJMPNZ: zTypeF("njmpnz $%04lX (-WHILE)", (long)x); i++; break;
268 | 			default: x = findXT(op); 
269 | 				zType(x ? ((DE_T*)x)->nm : "??");
270 | 		}
271 | 	}
272 | }
273 | 
274 | void iToA(cell n, cell b) {
275 | 	if (n<0) { emit('-'); n = -n; }
276 | 	if (b<=n) { iToA(n/b, b); }
277 | 	n %= b; if (9<n) { n += 7; }
278 | 	emit('0'+(char)n);
279 | }
280 | 
281 | void fType(const char *s) {
282 | 	while (*s) {
283 | 		char c = *(s++);
284 | 		if (c=='%') {
285 | 			c = *(s++);
286 | 			switch (c) {
287 | 				case  'B': Blue();
288 | 				BCASE 'G': Green();
289 | 				BCASE 'P': Purple();
290 | 				BCASE 'R': Red();
291 | 				BCASE 'S': zType((char*)pop());
292 | 				BCASE 'W': White();
293 | 				BCASE 'Y': Yellow();
294 | 				BCASE 'b': iToA(pop(),2);
295 | 				BCASE 'c': emit((char)pop());
296 | 				BCASE 'd': iToA(pop(),10);
297 | 				BCASE 'e': emit(27);
298 | 				BCASE 'i': iToA(pop(),base);
299 | 				BCASE 'n': emit(13); emit(10);
300 | 				BCASE 'q': emit('"');
301 | 				BCASE 's': fType((char*)pop());
302 | 				BCASE 'x': iToA(pop(),16); break;
303 | 				default: emit(c); break;
304 | 			}
305 | 		} else { emit(c); }
306 | 	}
307 | }
308 | 
309 | void compileNum(cell num) {
310 | 	if (btwi(num, 0, NUM_MASK)) { comma((wc_t)(num | NUM_BITS)); }
311 | 	else { comma(LIT); commaCell(num); }
312 | }
313 | 
314 | void quote() {
315 | 	char *vh=(char*)vhere;
316 | 	if (*toIn) { ++toIn; }
317 | 	while (*toIn) {
318 | 		if (*toIn == '"') { ++toIn; break; }
319 | 		*(vh++) = *(toIn++);
320 | 	}
321 | 	*(vh++) = 0; // NULL terminator
322 | 	push(vhere);
323 | 	if (state == COMPILE) {
324 | 		compileNum(pop());
325 | 		vhere = (cell)vh;
326 | 	}
327 | }
328 | 
329 | #undef X
330 | #define X(op, name, imm, code) NCASE op: code
331 | 
332 | void inner(wc_t start) {
333 | 	cell t, n;
334 | 	wc_t pc = start, wc;
335 | 	next:
336 | 	wc = code[pc++];
337 | 	switch(wc) {
338 | 		case  STOP:   return;
339 | 		NCASE LIT:    push(fetchCell((cell)&code[pc])); pc += (CELL_SZ/WC_SZ);
340 | 		NCASE JMP:    pc=code[pc];
341 | 		NCASE JMPZ:   if (pop()==0) { pc=code[pc]; } else { ++pc; }
342 | 		NCASE NJMPZ:  if (TOS==0) { pc=code[pc]; } else { ++pc; }
343 | 		NCASE JMPNZ:  if (pop()) { pc=code[pc]; } else { ++pc; }
344 | 		NCASE NJMPNZ: if (TOS) { pc=code[pc]; } else { ++pc; }
345 | 		PRIMS_BASE PRIMS_FILE PRIMS_SYSTEM
346 | 		goto next; default:
347 | 			if ((wc & NUM_BITS) == NUM_BITS) { push(wc & NUM_MASK); goto next; }
348 | 			if (code[pc] != EXIT) { rpush(pc); }
349 | 			pc = wc;
350 | 			goto next;
351 | 	}
352 | }
353 | 
354 | int isNum(const char *w, int b) {
355 | 	cell n=0, isNeg=0;
356 | 	if ((w[0]==39) && (w[2]==39) && (w[3]==0)) { push(w[1]); return 1; }
357 | 	if (w[0]=='%') { b= 2; ++w; }
358 | 	if (w[0]=='#') { b=10; ++w; }
359 | 	if (w[0]=='$') { b=16; ++w; }
360 | 	if ((b==10) && (w[0]=='-')) { isNeg=1; ++w; }
361 | 	if (w[0]==0) { return 0; }
362 | 	char c = lower(*(w++));
363 | 	while (c) {
364 | 		n = (n*b);
365 | 		if (btwi(c,'0','9') &&  btwi(c,'0','0'+b-1)) { n+=(c-'0'); }
366 | 		else if (btwi(c,'a','a'+b-11)) { n+=(c-'a'+10); }
367 | 		else return 0;
368 | 		c = lower(*(w++));
369 | 	}
370 | 	if (isNeg) { n = -n; }
371 | 	push(n);
372 | 	return 1;
373 | }
374 | 
375 | void executeWord(DE_T *de) {
376 | 	code[17] = de->xt;
377 | 	code[18] = STOP;
378 | 	inner(17);
379 | }
380 | 
381 | void compileWord(DE_T *de) {
382 | 	if (de->fl & _IMMED) { executeWord(de); }
383 | 	else if (de->fl & _INLINE) {
384 | 		wc_t x = de->xt;
385 | 		do { comma(code[x++]); } while (code[x]!=EXIT);
386 | 	} else { comma(de->xt); }
387 | }
388 | 
389 | int isStateChange(const char *wd) {
390 | 	static int prevState = INTERP;
391 | 	if (prevState == COMMENT) { prevState = INTERP; }
392 | 	if (strEq(wd, ")")) { return changeState(prevState); }
393 | 	if (state==COMMENT) { return 0; }
394 | 	if (strEq(wd,":")) { return changeState(DEFINE); }
395 | 	if (strEq(wd,"[")) { return changeState(INTERP); }
396 | 	if (strEq(wd,"]")) { return changeState(COMPILE); }
397 | 	if (strEq(wd,"(")) {
398 | 		if (state!=COMMENT) { prevState=state; }
399 | 		return changeState(COMMENT);
400 | 	}
401 | 	return 0;
402 | }
403 | 
404 | void outer(const char *ln) {
405 | 	// zTypeF("-outer:%s-\n",ln);
406 | 	char *curIn = toIn;
407 | 	toIn = (char*)ln;
408 | 	while (nextWord()) {
409 | 		// zTypeF("-word:(%s,%d)-",wd,state);
410 | 		if (isStateChange(wd)) { continue; }
411 | 		if (state == COMMENT) { continue; }
412 | 		if (state == DEFINE) { addWord(wd); state = COMPILE; continue; }
413 | 		if (isNum(wd, base)) {
414 | 			if (state == COMPILE) { compileNum(pop()); }
415 | 			continue;
416 | 		}
417 | 		DE_T *de = findWord(wd);
418 | 		if (de) {
419 | 			if (state == COMPILE) { compileWord(de); }
420 | 			else { executeWord(de); }
421 | 			continue;
422 | 		}
423 | 		zTypeF("-%s?-", wd);
424 | 		if (inputFp) { zTypeF(" at\r\n\t%s", ln); }
425 | 		state = INTERP;
426 | 		while (inputFp) { fileClose(inputFp); inputFp = filePop(); }
427 | 		break;
428 | 	}
429 | 	toIn = curIn;
430 | }
431 | 
432 | void outerF(const char *fmt, ...) {
433 | 	char buf[128];
434 | 	va_list args;
435 | 	va_start(args, fmt);
436 | 	vsnprintf(buf, 128, fmt, args);
437 | 	va_end(args);
438 | 	outer(buf);
439 | }
440 | 
441 | void zTypeF(const char *fmt, ...) {
442 | 	char buf[128];
443 | 	va_list args;
444 | 	va_start(args, fmt);
445 | 	vsnprintf(buf, 128, fmt, args);
446 | 	va_end(args);
447 | 	zType(buf);
448 | }
449 | 
450 | void defNum(const char *name, cell val) {
451 | 	DE_T *dp = addWord(name);
452 | 	compileNum(val);
453 | 	comma(EXIT);
454 | 	if (btwi(val,0,NUM_MASK)) { dp->fl = _INLINE; }
455 | }
456 | 
457 | void baseSys() {
458 | 	for (int i = 0; prims[i].name; i++) {
459 | 		DE_T *w = addWord(prims[i].name);
460 | 		w->xt = prims[i].op;
461 | 		w->fl = prims[i].fl;
462 | 	}
463 | 	defNum("mem-sz",      MEM_SZ);
464 | 	defNum("code-sz",     CODE_SLOTS);
465 | 	defNum("de-sz",       sizeof(DE_T));
466 | 	defNum("dstk-sz",     STK_SZ+1);
467 | 	defNum("tstk-sz",     TSTK_SZ+1);
468 | 	defNum("wc-sz",       WC_SZ);
469 | 	defNum("(dsp)",       DSPA);
470 | 	defNum("(rsp)",       RSPA);
471 | 	defNum("(lsp)",       LSPA);
472 | 	defNum("(tsp)",       TSPA);
473 | 	defNum("(asp)",       ASPA);
474 | 	defNum("(bsp)",       BSPA);
475 | 	defNum("(block)",     BLKA);
476 | 	defNum("dstk",        (cell)&dstk[0]);
477 | 	defNum("rstk",        (cell)&rstk[0]);
478 | 	defNum("tstk",        (cell)&tstk[0]);
479 | 	defNum("astk",        (cell)&astk[0]);
480 | 	defNum("bstk",        (cell)&bstk[0]);
481 | 	defNum("memory",      (cell)&memory[0]);
482 | 	defNum("vars",        vhere);
483 | 	defNum(">in",         (cell)&toIn);
484 | 	defNum("wd",          (cell)&wd[0]);
485 | 	defNum("(vhere)",     (cell)&vhere);
486 | 	defNum("(output-fp)", (cell)&outputFp);
487 | 	defNum("(last)",      (cell)&last);
488 | 	defNum("version",     VERSION);
489 | 	defNum("(lit)",       LIT);
490 | 	defNum("(jmp)",       JMP);
491 | 	defNum("(jmpz)",      JMPZ);
492 | 	defNum("(njmpz)",     NJMPZ);
493 | 	defNum("(jmpnz)",     JMPNZ);
494 | 	defNum("(njmpnz)",    NJMPNZ);
495 | 	defNum("(exit)",      EXIT);
496 | 	defNum("(here)",      HA);
497 | 	defNum("base",        BA);
498 | 	defNum("state",       SA);
499 | 	defNum("cell",        CELL_SZ);
500 | 	sys_load();
501 | }
502 | 
503 | void c4Init() {
504 | 	code = (wc_t*)&memory[0];
505 | 	here = BYE+1;
506 | 	last = (DE_T*)&memory[MEM_SZ];
507 | 	base = 10;
508 | 	state = INTERP;
509 | 	vhere = (cell)&memory[CODE_SLOTS*WC_SZ];
510 | 	for (int i=6; i<=9; i++) { tmpWords[i].fl = _INLINE; }
511 | 	fileInit();
512 | 	baseSys();
513 | }
514 | 


--------------------------------------------------------------------------------
/c4.h:
--------------------------------------------------------------------------------
  1 | #ifndef __C4_H__
  2 | 
  3 | #define __C4_H__
  4 | 
  5 | #define VERSION   20250725
  6 | 
  7 | #ifdef _MSC_VER
  8 |   #define _CRT_SECURE_NO_WARNINGS
  9 |   #define IS_WINDOWS 1
 10 | #else
 11 |   #define IS_LINUX   1
 12 | #endif
 13 | 
 14 | #define MEM_SZ          16*1024*1024
 15 | #define CODE_SLOTS    0xE000
 16 | #define STK_SZ          63  // Both data and return stacks
 17 | #define LSTK_SZ         60  // 3 cells per entry
 18 | #define TSTK_SZ         63  // A, B and T stacks
 19 | #define FSTK_SZ         15  // File stack
 20 | #define NAME_LEN        19  // DE-SZ = 2+1+1+LEN+1
 21 | #define _SYS_LOAD_
 22 | #define EDITOR
 23 | 
 24 | #include <stdio.h>
 25 | #include <stdlib.h>
 26 | #include <stdarg.h>
 27 | #include <stdint.h>
 28 | #include <time.h>
 29 | 
 30 | #define btwi(n,l,h)   ((l<=n) && (n<=h))
 31 | #define _IMMED           1
 32 | #define _INLINE          2
 33 | 
 34 | #define WC_T          uint16_t
 35 | #define WC_SZ            2
 36 | #define NUM_BITS       0xE000
 37 | #define NUM_MASK       0x1FFF
 38 | 
 39 | #if INTPTR_MAX > INT32_MAX
 40 |     #define CELL_T        int64_t
 41 |     #define CELL_SZ       8
 42 | #else
 43 |     #define CELL_T        int32_t
 44 |     #define CELL_SZ       4
 45 | #endif
 46 | 
 47 | enum { COMPILE=1, DEFINE=2, INTERP=3, COMMENT=4 };
 48 | enum { DSPA=0, RSPA, LSPA, TSPA, ASPA, BSPA, HA, BA, SA, BLKA };
 49 | 
 50 | typedef CELL_T cell;
 51 | typedef WC_T wc_t;
 52 | typedef uint8_t byte;
 53 | typedef struct { wc_t xt; byte fl, ln; char nm[NAME_LEN+1]; } DE_T;
 54 | typedef struct { const char *name; wc_t op; byte fl; byte pad; } PRIM_T;
 55 | 
 56 | // These are defined by c4.c
 57 | extern void push(cell x);
 58 | extern cell pop();
 59 | extern void storeWC(wc_t a, wc_t v);
 60 | extern wc_t fetchWC(wc_t a);
 61 | extern void strCpy(char *d, const char *s);
 62 | extern int  strFind(const char *buf, const char *lookFor, int start);
 63 | extern int  strEq(const char *d, const char *s);
 64 | extern int  strEqI(const char *d, const char *s);
 65 | extern int  strLen(const char *s);
 66 | extern int  lower(const char c);
 67 | extern void zTypeF(const char *fmt, ...);
 68 | extern int  changeState(int x);
 69 | extern void inner(wc_t start);
 70 | extern void outer(const char *src);
 71 | extern void outerF(const char *fmt, ...);
 72 | extern void c4Init();
 73 | extern void ok();
 74 | 
 75 | // These are in the editor
 76 | extern void FG(int fg);
 77 | extern void Blue();
 78 | extern void Green();
 79 | extern void Purple();
 80 | extern void Red();
 81 | extern void White();
 82 | extern void Yellow();
 83 | 
 84 | // c4.c needs these to be defined
 85 | extern cell inputFp, outputFp;
 86 | extern void zType(const char *str);
 87 | extern void emit(const char ch);
 88 | extern void ttyMode(int isRaw);
 89 | extern int  key();
 90 | extern int  qKey();
 91 | extern cell timer();
 92 | extern void fileInit();
 93 | extern void filePush(cell fh);
 94 | extern cell filePop();
 95 | extern cell fileOpen(const char *name, const char *mode);
 96 | extern void fileClose(cell fh);
 97 | extern void fileDelete(const char *name);
 98 | extern cell fileRead(char *buf, int sz, cell fh);
 99 | extern cell fileWrite(char *buf, int sz, cell fh);
100 | extern int  fileGets(char *buf, int sz, cell fh);
101 | extern void fileLoad(const char *name);
102 | extern char *blockFn(int blk);
103 | extern void blockLoad(int blk);
104 | extern void blockLoadNext(int blk);
105 | extern void sys_load();
106 | extern void editBlock(cell blk);
107 | 
108 | #endif //  __C4_H__
109 | 


--------------------------------------------------------------------------------
/c4.sln:
--------------------------------------------------------------------------------
 1 | 
 2 | Microsoft Visual Studio Solution File, Format Version 12.00
 3 | # Visual Studio Version 16
 4 | VisualStudioVersion = 16.0.31112.23
 5 | MinimumVisualStudioVersion = 10.0.40219.1
 6 | Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "c4", "c4.vcxproj", "{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}"
 7 | EndProject
 8 | Global
 9 | 	GlobalSection(SolutionConfigurationPlatforms) = preSolution
10 | 		Debug|x64 = Debug|x64
11 | 		Debug|x86 = Debug|x86
12 | 		Release|x64 = Release|x64
13 | 		Release|x86 = Release|x86
14 | 	EndGlobalSection
15 | 	GlobalSection(ProjectConfigurationPlatforms) = postSolution
16 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Debug|x64.ActiveCfg = Debug|x64
17 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Debug|x64.Build.0 = Debug|x64
18 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Debug|x86.ActiveCfg = Debug|Win32
19 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Debug|x86.Build.0 = Debug|Win32
20 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Release|x64.ActiveCfg = Release|x64
21 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Release|x64.Build.0 = Release|x64
22 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Release|x86.ActiveCfg = Release|Win32
23 | 		{BDD1C19E-3EEC-4DDF-AD67-406628BACCCF}.Release|x86.Build.0 = Release|Win32
24 | 	EndGlobalSection
25 | 	GlobalSection(SolutionProperties) = preSolution
26 | 		HideSolutionNode = FALSE
27 | 	EndGlobalSection
28 | 	GlobalSection(ExtensibilityGlobals) = postSolution
29 | 		SolutionGuid = {C2304CB4-4ACA-4A41-9669-EACD091DD0F1}
30 | 	EndGlobalSection
31 | EndGlobal
32 | 


--------------------------------------------------------------------------------
/c4.vcxproj:
--------------------------------------------------------------------------------
  1 | <?xml version="1.0" encoding="utf-8"?>
  2 | <Project DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
  3 |   <ItemGroup Label="ProjectConfigurations">
  4 |     <ProjectConfiguration Include="Debug|Win32">
  5 |       <Configuration>Debug</Configuration>
  6 |       <Platform>Win32</Platform>
  7 |     </ProjectConfiguration>
  8 |     <ProjectConfiguration Include="Release|Win32">
  9 |       <Configuration>Release</Configuration>
 10 |       <Platform>Win32</Platform>
 11 |     </ProjectConfiguration>
 12 |     <ProjectConfiguration Include="Debug|x64">
 13 |       <Configuration>Debug</Configuration>
 14 |       <Platform>x64</Platform>
 15 |     </ProjectConfiguration>
 16 |     <ProjectConfiguration Include="Release|x64">
 17 |       <Configuration>Release</Configuration>
 18 |       <Platform>x64</Platform>
 19 |     </ProjectConfiguration>
 20 |   </ItemGroup>
 21 |   <PropertyGroup Label="Globals">
 22 |     <VCProjectVersion>16.0</VCProjectVersion>
 23 |     <Keyword>Win32Proj</Keyword>
 24 |     <ProjectGuid>{bdd1c19e-3eec-4ddf-ad67-406628bacccf}</ProjectGuid>
 25 |     <RootNamespace>stable</RootNamespace>
 26 |     <WindowsTargetPlatformVersion>10.0</WindowsTargetPlatformVersion>
 27 |     <ProjectName>c4</ProjectName>
 28 |   </PropertyGroup>
 29 |   <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" />
 30 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration">
 31 |     <ConfigurationType>Application</ConfigurationType>
 32 |     <UseDebugLibraries>true</UseDebugLibraries>
 33 |     <PlatformToolset>v143</PlatformToolset>
 34 |     <CharacterSet>MultiByte</CharacterSet>
 35 |   </PropertyGroup>
 36 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration">
 37 |     <ConfigurationType>Application</ConfigurationType>
 38 |     <UseDebugLibraries>false</UseDebugLibraries>
 39 |     <PlatformToolset>v143</PlatformToolset>
 40 |     <WholeProgramOptimization>true</WholeProgramOptimization>
 41 |     <CharacterSet>MultiByte</CharacterSet>
 42 |   </PropertyGroup>
 43 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration">
 44 |     <ConfigurationType>Application</ConfigurationType>
 45 |     <UseDebugLibraries>true</UseDebugLibraries>
 46 |     <PlatformToolset>v143</PlatformToolset>
 47 |     <CharacterSet>Unicode</CharacterSet>
 48 |   </PropertyGroup>
 49 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration">
 50 |     <ConfigurationType>Application</ConfigurationType>
 51 |     <UseDebugLibraries>false</UseDebugLibraries>
 52 |     <PlatformToolset>v143</PlatformToolset>
 53 |     <WholeProgramOptimization>true</WholeProgramOptimization>
 54 |     <CharacterSet>Unicode</CharacterSet>
 55 |   </PropertyGroup>
 56 |   <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" />
 57 |   <ImportGroup Label="ExtensionSettings">
 58 |   </ImportGroup>
 59 |   <ImportGroup Label="Shared">
 60 |   </ImportGroup>
 61 |   <ImportGroup Label="PropertySheets" Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">
 62 |     <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
 63 |   </ImportGroup>
 64 |   <ImportGroup Label="PropertySheets" Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">
 65 |     <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
 66 |   </ImportGroup>
 67 |   <ImportGroup Label="PropertySheets" Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">
 68 |     <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
 69 |   </ImportGroup>
 70 |   <ImportGroup Label="PropertySheets" Condition="'$(Configuration)|$(Platform)'=='Release|x64'">
 71 |     <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
 72 |   </ImportGroup>
 73 |   <PropertyGroup Label="UserMacros" />
 74 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">
 75 |     <LinkIncremental>true</LinkIncremental>
 76 |   </PropertyGroup>
 77 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">
 78 |     <LinkIncremental>false</LinkIncremental>
 79 |   </PropertyGroup>
 80 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">
 81 |     <LinkIncremental>true</LinkIncremental>
 82 |   </PropertyGroup>
 83 |   <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'">
 84 |     <LinkIncremental>false</LinkIncremental>
 85 |   </PropertyGroup>
 86 |   <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">
 87 |     <ClCompile>
 88 |       <WarningLevel>Level3</WarningLevel>
 89 |       <SDLCheck>true</SDLCheck>
 90 |       <PreprocessorDefinitions>WIN32;_DEBUG;_CONSOLE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
 91 |       <ConformanceMode>true</ConformanceMode>
 92 |       <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed>
 93 |     </ClCompile>
 94 |     <Link>
 95 |       <SubSystem>Console</SubSystem>
 96 |       <GenerateDebugInformation>true</GenerateDebugInformation>
 97 |     </Link>
 98 |   </ItemDefinitionGroup>
 99 |   <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">
100 |     <ClCompile>
101 |       <WarningLevel>Level3</WarningLevel>
102 |       <FunctionLevelLinking>true</FunctionLevelLinking>
103 |       <IntrinsicFunctions>true</IntrinsicFunctions>
104 |       <SDLCheck>true</SDLCheck>
105 |       <PreprocessorDefinitions>WIN32;NDEBUG;_CONSOLE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
106 |       <ConformanceMode>true</ConformanceMode>
107 |       <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed>
108 |       <AssemblerOutput>AssemblyAndSourceCode</AssemblerOutput>
109 |       <Optimization>Full</Optimization>
110 |     </ClCompile>
111 |     <Link>
112 |       <SubSystem>Console</SubSystem>
113 |       <EnableCOMDATFolding>true</EnableCOMDATFolding>
114 |       <OptimizeReferences>true</OptimizeReferences>
115 |       <GenerateDebugInformation>true</GenerateDebugInformation>
116 |     </Link>
117 |   </ItemDefinitionGroup>
118 |   <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">
119 |     <ClCompile>
120 |       <WarningLevel>Level3</WarningLevel>
121 |       <SDLCheck>true</SDLCheck>
122 |       <PreprocessorDefinitions>_DEBUG;_CONSOLE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
123 |       <ConformanceMode>true</ConformanceMode>
124 |     </ClCompile>
125 |     <Link>
126 |       <SubSystem>Console</SubSystem>
127 |       <GenerateDebugInformation>true</GenerateDebugInformation>
128 |     </Link>
129 |   </ItemDefinitionGroup>
130 |   <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'">
131 |     <ClCompile>
132 |       <WarningLevel>Level3</WarningLevel>
133 |       <FunctionLevelLinking>true</FunctionLevelLinking>
134 |       <IntrinsicFunctions>true</IntrinsicFunctions>
135 |       <SDLCheck>true</SDLCheck>
136 |       <PreprocessorDefinitions>NDEBUG;_CONSOLE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
137 |       <ConformanceMode>true</ConformanceMode>
138 |     </ClCompile>
139 |     <Link>
140 |       <SubSystem>Console</SubSystem>
141 |       <EnableCOMDATFolding>true</EnableCOMDATFolding>
142 |       <OptimizeReferences>true</OptimizeReferences>
143 |       <GenerateDebugInformation>true</GenerateDebugInformation>
144 |     </Link>
145 |   </ItemDefinitionGroup>
146 |   <ItemGroup>
147 |     <None Include=".gitignore" />
148 |     <None Include="block-003.fth" />
149 |     <None Include="block-004.fth" />
150 |     <None Include="block-005.fth" />
151 |     <None Include="block-006.fth" />
152 |     <None Include="block-007.fth" />
153 |     <None Include="block-010.fth" />
154 |     <None Include="block-020.fth" />
155 |     <None Include="block-021.fth" />
156 |     <None Include="block-022.fth" />
157 |     <None Include="block-023.fth" />
158 |     <None Include="block-024.fth" />
159 |     <None Include="block-025.fth" />
160 |     <None Include="block-026.fth" />
161 |     <None Include="block-200.fth" />
162 |     <None Include="block-999.fth" />
163 |     <None Include="Editor.md" />
164 |     <None Include="LICENSE" />
165 |     <None Include="makefile" />
166 |     <None Include="README.md" />
167 |   </ItemGroup>
168 |   <ItemGroup>
169 |     <ClCompile Include="c4.c" />
170 |     <ClCompile Include="editor.c" />
171 |     <ClCompile Include="sys-load.c" />
172 |     <ClCompile Include="system.c" />
173 |   </ItemGroup>
174 |   <ItemGroup>
175 |     <ClInclude Include="c4.h" />
176 |     <ClCompile Include="file-pc.c">
177 |       <ExcludedFromBuild Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</ExcludedFromBuild>
178 |       <FileType>CppCode</FileType>
179 |       <ExcludedFromBuild Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</ExcludedFromBuild>
180 |     </ClCompile>
181 |   </ItemGroup>
182 |   <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" />
183 |   <ImportGroup Label="ExtensionTargets">
184 |   </ImportGroup>
185 | </Project>


--------------------------------------------------------------------------------
/editor.c:
--------------------------------------------------------------------------------
  1 | // editor.cpp - A simple block editor
  2 | 
  3 | #include "c4.h"
  4 | 
  5 | void FG(int fg) { zTypeF("\x1B[38;5;%dm", fg); }
  6 | void Blue() { FG(38); }
  7 | void Green() { FG(40); }
  8 | void Purple() { FG(213); }
  9 | void Red() { FG(203); }
 10 | void White() { FG(231); }
 11 | void Yellow() { FG(226); }
 12 | void BG(int c) { zTypeF("\x1B[48;5;%dm", c); }
 13 | 
 14 | #ifndef EDITOR
 15 | void editBlock(cell blk) { zType("-no edit-"); }
 16 | #else
 17 | 
 18 | #define NUM_LINES     32
 19 | #define NUM_COLS      96
 20 | #define BLOCK_SZ      (NUM_LINES*NUM_COLS)
 21 | #define MAX_LINE      (NUM_LINES-1)
 22 | #define MAX_COL       (NUM_COLS-1)
 23 | #define EDCH(r,c)     edBuf[((r)*NUM_COLS)+(c)]
 24 | #define DIRTY         isDirty=1; isShow=1
 25 | #define CLEAN(show)   isDirty=0; isShow=show
 26 | #define BCASE         break; case
 27 | #define RCASE         return; case
 28 | #define EOL_CHAR      13
 29 | 
 30 | #ifndef MAX
 31 |   #define MIN(a,b) ((a)<(b))?(a):(b)
 32 |   #define MAX(a,b) ((a)>(b))?(a):(b)
 33 | #endif
 34 | 
 35 | enum { NORMAL=1, INSERT, REPLACE, QUIT };
 36 | enum { Up=7240, Dn=7248, Rt=7245, Lt=7243, Home=7239, PgUp=7241, PgDn=7249,
 37 |     End=7247, Ins=7250, Del=7251, CHome=7287, CEnd=7285,
 38 |     STab=12333, F1=0xF01, F5=0xF05, F6=0xF06, F7=0xF07
 39 | };
 40 | 
 41 | static int line, off, edMode, isDirty, isShow, block, lastBlock;
 42 | static char edBuf[BLOCK_SZ], yanked[NUM_COLS+1], findBuf[32];
 43 | 
 44 | static void GotoXY(int x, int y) { zTypeF("\x1B[%d;%dH", y, x); }
 45 | static void CLS() { zType("\x1B[2J"); GotoXY(1, 1); }
 46 | static void ClearEOL() { zType("\x1B[K"); }
 47 | static void CursorBlock() { zType("\x1B[2 q"); }
 48 | static void CursorOn() { zType("\x1B[?25h"); }
 49 | static void CursorOff() { zType("\x1B[?25l"); }
 50 | static void showCursor() { GotoXY(off+2, line+2); CursorOn(); CursorBlock(); }
 51 | static void topBottom() { for (int i=0; i<=(NUM_COLS/2); i++) { zType("--"); } }
 52 | static void toFooter() { GotoXY(1, NUM_LINES+3); }
 53 | static void toCmd() { GotoXY(1, NUM_LINES+4); }
 54 | static void normalMode()  { edMode=NORMAL;  }
 55 | static void insertMode()  { edMode=INSERT;  }
 56 | static void replaceMode() { edMode=REPLACE; }
 57 | static void toggleInsert() { (edMode==INSERT) ? normalMode() : insertMode(); }
 58 | static void setBlock(int blk) { block=MAX(MIN(blk,999),0); storeWC(BLKA, (wc_t)block); }
 59 | static int  winKey() { return (224 << 5) ^ key(); }
 60 | static int  winFKey() { return 0xF00 + key() - 58; }
 61 | 
 62 | // VT key mapping, after <escape>, '['
 63 | #define NUM_VTK 16
 64 | static int vks[NUM_VTK][7] = {
 65 |         { 0, 49, 53, 126, 999, F5 },
 66 |         { 0, 49, 55, 126, 999, F6 },
 67 |         { 0, 49, 56, 126, 999, F7 },
 68 |         { 0, 49, 59, 53, 72, 999, CHome },
 69 |         { 0, 49, 59, 53, 70, 999, CEnd },
 70 |         { 0, 50, 126, 999, Ins },
 71 |         { 0, 51, 126, 999, Del },
 72 |         { 0, 53, 126, 999, PgUp },
 73 |         { 0, 54, 126, 999, PgDn },
 74 |         { 0, 65, 999, Up },
 75 |         { 0, 66, 999, Dn },
 76 |         { 0, 67, 999, Rt },
 77 |         { 0, 68, 999, Lt },
 78 |         { 0, 70, 999, End },
 79 |         { 0, 72, 999, Home },
 80 |         { 0, 90, 999, STab },
 81 |     };
 82 | 
 83 | static int vtKey() {
 84 |     if (key() != '[') { return 27; }
 85 |     int ndx = 0, k, m;
 86 |     for (int i=0; i<NUM_VTK; i++) { vks[i][0] = 1; }
 87 |     while (++ndx < 5) {
 88 |         m = 0;
 89 |         k = key();
 90 |         for (int i=0; i<NUM_VTK; i++) {
 91 |             if ((vks[i][0] == ndx) && (vks[i][ndx] == k)) {
 92 |                 if (vks[i][ndx+1] == 999) { return vks[i][ndx+2]; }
 93 |                 vks[i][0] = ndx+1;
 94 |                 m++;
 95 |             }
 96 |         }
 97 |         if (m == 0) { return 27; }
 98 |     }
 99 |     return 27;
100 | }
101 | 
102 | static int edKey() {
103 |     int x = key();
104 |     if (x ==   0) { return winFKey(); }  // Windows: Function key
105 |     if (x ==  27) { return vtKey(); }    // Possible VT control sequence
106 |     if (x == 224) { return winKey(); }   // Windows: start char
107 |     return x;
108 | }
109 | 
110 | static void mv(int r, int c) {
111 |     line += r;
112 |     off += c;
113 |     if (line < 0) { line = 0; }
114 |     if (MAX_LINE < line) { line = MAX_LINE; }
115 |     if (off < 0) { off=0; }
116 |     if (MAX_COL < off) { off = MAX_COL;}
117 | }
118 | 
119 | static void mvLeft() { mv(0,-1); }
120 | static void mvRight() { mv(0,1); }
121 | static void mvUp() { mv(-1,0); }
122 | static void mvDown() { mv(1,0); }
123 | static void mvNextLine() { mv(1,-99); }
124 | static void mvPrevLine() { mv(-1,-99); }
125 | 
126 | static void moveWord(int isRight) {
127 |     if (isRight) {
128 |         while ((off < MAX_COL) & (EDCH(line,off) > 32)) { ++off; }
129 |         while ((off < MAX_COL) & (EDCH(line,off) < 33)) { ++off; }
130 |     } else {
131 |         while ((0 < off) & (EDCH(line,off-1) < 33)) { --off; }
132 |         while ((0 < off) & (EDCH(line,off-1) > 32)) { --off; }
133 |     }
134 | }
135 | 
136 | static void showState(char ch) {
137 |     static int lastState = INTERP;
138 |     if (ch == -1) { lastState = INTERP; return; }
139 |     int cols[4] = { 40, 203, 226, 231 };
140 |     if (ch == 0) { ch = (lastState) ? lastState : INTERP; }
141 |     if (btwi(ch,1,4)) { FG(cols[ch-1]); lastState = ch; }
142 | }
143 | 
144 | static void gotoEOL() {
145 |     off = MAX_COL;
146 |     if (EDCH(line, off) > 32) { return; }
147 |     while (off && (EDCH(line, off-1) < 33)) { --off; }
148 | }
149 | 
150 | static void copyLine(char *from, char *to, int nullTerm) {
151 |     for (int c=0; c<NUM_COLS; c++) { *(to++) = *(from++); }
152 |     if (nullTerm) { *to = 0; }
153 | }
154 | 
155 | static void yankLine(int lineNum, char *to) {
156 |     copyLine(&EDCH(lineNum, 0), to, 1);
157 | }
158 | 
159 | static void edRdBlk() {
160 |     for (int i=0; i<BLOCK_SZ; i++) { edBuf[i]=32; }
161 |     toCmd();
162 |     cell fh = fileOpen(blockFn(block), "rb");
163 |     if (fh) {
164 |         char x[BLOCK_SZ+1];
165 |         int r=0, c=0, n=fileRead(x, BLOCK_SZ, fh);
166 |         zTypeF("%d chars", n);
167 |         fileClose(fh);
168 |         for (int i=0; i<n; i++) {
169 |             char ch=x[i];
170 |             if (ch==13) { continue; }
171 |             if (ch==9) { ch=32; }
172 |             if (ch==10) {
173 |                 if (r == MAX_LINE) { break; }
174 |                 r++; c=0;
175 |             } else { EDCH(r,c)=ch; c++; }
176 |         }
177 |     } else { zTypeF("-can't open [%s]!-", blockFn(block)); }
178 |     ClearEOL();
179 |     CLEAN(1);
180 | }
181 | 
182 | static void edSvBlk(int force) {
183 |     if (!isDirty && !force) { return; }
184 |     char x[NUM_COLS+1];
185 |     cell fh = fileOpen(blockFn(block), "wb");
186 |     if (fh) {
187 |         outputFp = fh;
188 |         for (int r=0; r<NUM_LINES; r++) {
189 |             yankLine(r, x);
190 |             if (x[MAX_COL]==0) { x[MAX_COL] = 32; }
191 |             for (int r=MAX_COL; 0 <= r; r--) {
192 |                 if (x[r]==32) { x[r] = 0; }
193 |                 else { break; }
194 |             }
195 |             zType(x);
196 |             emit(10);
197 |         }
198 |         outputFp = 0;
199 |         fileClose(fh);
200 |         toCmd(); zType("-saved-"); ClearEOL();
201 |     }
202 |     CLEAN(0);
203 | }
204 | 
205 | static void deleteChar(int toEnd) {
206 |     char *f = &EDCH(line, off);
207 |     char *t = toEnd ? &EDCH(MAX_LINE, MAX_COL) : &EDCH(line, MAX_COL);
208 |     while (f < t) { *(f) = *(f+1); f++; }
209 |     *f = 32;
210 |     DIRTY;
211 | }
212 | 
213 | static void deleteWord() {
214 |     while (EDCH(line,off) > 32) { deleteChar(0); }
215 |     for (int i=0; i<20; i++) { if (EDCH(line,off)<33) { deleteChar(0); } }
216 | }
217 | 
218 | static void clrToEOL(int l, int o) {
219 |     while (o<NUM_COLS) { EDCH(l,o)=32; o++; }
220 |     DIRTY;
221 | }
222 | 
223 | static void putLine(int l) {
224 |     copyLine(yanked, &EDCH(l, 0), 0);
225 | }
226 | 
227 | static void deleteLine(int l) {
228 |     for (int r=l; r<MAX_LINE; r++) { copyLine(&EDCH(r+1, 0), &EDCH(r, 0), 0); }
229 |     clrToEOL(MAX_LINE, 0);
230 | }
231 | 
232 | static void insertSpace(int toEnd) {
233 |     if (toEnd) {
234 |         char *f = &EDCH(line,off);
235 |         char *t = &EDCH(MAX_LINE,MAX_COL);
236 |         while (f<t) { *(t) = *(t-1); t--; }
237 |     } else {
238 |         for (int o=MAX_COL; off<o; o--) {
239 |             EDCH(line,o) = EDCH(line, o-1);
240 |         }
241 |     }
242 |     EDCH(line, off)=32;
243 |     DIRTY;
244 | }
245 | 
246 | static void insertLine(int l, int o) {
247 |     for (int r=MAX_LINE; r>l; r--) {
248 |         char *f = &EDCH(r-1, 0);
249 |         char *t = &EDCH(r, 0);
250 |         for (int c=0; c<NUM_COLS; c++) { *(t++) = *(f++); }
251 |     }
252 |     clrToEOL(l, 0);
253 |     if (0 <= o) {
254 |         for (int i=o; i<NUM_COLS; i++) { EDCH(l,i-o) = EDCH(l-1,i); }
255 |         clrToEOL(l-1, o);
256 |     }
257 | }
258 | 
259 | static void joinLines() {
260 |     if (line == MAX_LINE) { return; }
261 |     gotoEOL();
262 |     int o = off+1;
263 |     char *t = &EDCH(line, o);
264 |     char *f = &EDCH(line+1, 0);
265 |     while ((o++) < NUM_COLS) { *(t++) = *(f++); }
266 |     deleteLine(line+1);
267 | }
268 | 
269 | static void execLine(int ln) {
270 |     char *x = &EDCH(ln,0);
271 |     char c = x[MAX_COL];
272 |     x[MAX_COL] = 0;
273 |     changeState(INTERP); ttyMode(0);
274 |     toCmd(); outer(x);
275 |     x[MAX_COL] = c;
276 | }
277 | 
278 | static void replaceChar(char c, int force, int mov) {
279 |     if (btwi(c,32,126) || (force)) {
280 |         EDCH(line, off)=c;
281 |         DIRTY;
282 |         if (mov) { mvRight(); }
283 |     }
284 | }
285 | 
286 | static void replace1() {
287 |     Purple(); zType("?\x08"); CursorOn();
288 |     int ch = key(); CursorOff();
289 |     replaceChar(ch, 0, 1);
290 |     isShow = 1;
291 | }
292 | 
293 | static int doInsertReplace(char c) {
294 |     if (c==EOL_CHAR) {
295 |         if (edMode == INSERT) { insertLine(line+1, off); }
296 |         mvNextLine();
297 |         return 1;
298 |     }
299 |     if (!btwi(c,1,5) && !btwi(c,32,126)) { return 1; }
300 |     if (edMode == INSERT) { insertSpace(0); }
301 |     replaceChar(c, 1, 1);
302 |     return 1;
303 | }
304 | 
305 | static void edDelX(int c) {
306 |     if (c==0) { c = key(); }
307 |     if (c=='d') { yankLine(line, yanked); deleteLine(line); }
308 |     else if (c=='w') { deleteWord(); }
309 |     else if (c=='.') { deleteChar(0); }
310 |     else if (c=='x') { deleteChar(0); }
311 |     else if (c=='X') { if (0<off) { --off; deleteChar(0); } }
312 |     else if (c=='$') { clrToEOL(line, off); }
313 |     else if (c=='Z') { deleteChar(1); }
314 | }
315 | 
316 | static int edReadLine(char *buf, int sz) {
317 |     int len = 0;
318 |     CursorOn();
319 |     while (len<(sz-1)) {
320 |         char c = key();
321 |         if (c == EOL_CHAR) { break; }
322 |         if (c ==  3) { len=0; break; }
323 |         if (c == 27) { len=0; break; }
324 |         if (((c==127) || (c==8)) && (0<len)) { --len; zType("\x08 \x08"); }
325 |         if (btwi(c,32,126)) { buf[len++]=c; emit(c); }
326 |     }
327 |     CursorOff();
328 |     buf[len]=0;
329 |     return len;
330 | }
331 | 
332 | static void gotoBlock(int blk) {
333 |     lastBlock = block;
334 |     edSvBlk(0); setBlock(blk);
335 |     edRdBlk(); line = off = 0;
336 | }
337 | 
338 | static void edCommand() {
339 |     char buf[32];
340 |     toCmd(); emit(':'); ClearEOL();
341 |     edReadLine(buf, sizeof(buf));
342 |     toCmd(); ClearEOL();
343 |     if (buf[0]=='!') {
344 |         wc_t curBlock = fetchWC(BLKA);
345 |         ttyMode(0); changeState(INTERP); outer(&buf[1]);
346 |         wc_t nowBlock = fetchWC(BLKA);
347 |         if (curBlock != nowBlock) { gotoBlock(nowBlock); }
348 |     }
349 |     else if (strEqI(buf,"rl")) { edRdBlk(); }
350 |     else if (strEqI(buf,"w")) { edSvBlk(0); }
351 |     else if (strEqI(buf,"w!")) { edSvBlk(1); }
352 |     else if (strEqI(buf,"wq")) { edSvBlk(0); edMode=QUIT; }
353 |     else if (strEqI(buf,"q!")) { edMode=QUIT; }
354 |     else if (strEqI(buf,"q")) {
355 |         if (isDirty) { zType("(use 'q!' to quit without saving)"); }
356 |         else { edMode=QUIT; }
357 |     }
358 | }
359 | 
360 | static void doFind(int next) {
361 |     if (findBuf[0] == 0) { return; }
362 |     int ln = line, o = next ? off+1 : 0;
363 |     do {
364 |         char *cp = &EDCH(ln,0), ch = cp[MAX_COL];
365 |         cp[MAX_COL] = 0;
366 |         o = strFind(cp, findBuf, o);
367 |         cp[MAX_COL] = ch;
368 |         if ((0 <= o) && ((ln != line) || (o != off))) {
369 |             line = ln; off = o; return;
370 |         }
371 |         o = 0;
372 |         ln += next ? 1 : -1;
373 |         if (ln < 0) { ln = MAX_LINE; }
374 |         if (MAX_LINE < ln) { ln = 0; }
375 |     } while (ln != line);
376 | }
377 | 
378 | static void cmdFind() {
379 |     toCmd(); emit('/'); ClearEOL();
380 |     edReadLine(findBuf, sizeof(findBuf));
381 |     toCmd(); ClearEOL();
382 |     isShow = 1;
383 |     doFind(1);
384 | }
385 | 
386 | static void doCTL(int c) {
387 |     if (c == EOL_CHAR) { doInsertReplace(c); return; }
388 |     if (((c == 8) || (c == 127)) && (0 < off)) {      // <backspace>
389 |         mvLeft(); if (edMode == INSERT) { deleteChar(0); }
390 |         return;
391 |     }
392 |     switch (c) {
393 |         case   1:    doInsertReplace(c);         // COMPLE
394 |         RCASE  2:    doInsertReplace(c);         // DEFINE
395 |         RCASE  3:    doInsertReplace(c);         // INTERP
396 |         RCASE  4:    doInsertReplace(c);         // COMMENT
397 |         RCASE  5:    execLine(line);             // Execute current line
398 |         RCASE  9:    mv(0, 8);                   // <tab>
399 |         RCASE 10:    mvDown();                   // <ctrl-j>
400 |         RCASE 11:    mvUp();                     // <ctrl-k>
401 |         RCASE 12:    mvRight();                  // <ctrl-l>
402 |         RCASE 17:    mv(0, -8);                  // <ctrl-q>
403 |         RCASE 24:    edDelX('.');                // <ctrl-x>
404 |         RCASE 20:    edSvBlk(0);                 // <ctrl-s>
405 |         RCASE 27:    normalMode();               // <escape>
406 |         RCASE Up:    mvUp();                     // Up
407 |         RCASE Lt:    mvLeft();                   // Left
408 |         RCASE Rt:    mvRight();                  // Right
409 |         RCASE Dn:    mvDown();                   // Down
410 |         RCASE Home:  mv(0, -NUM_COLS);           // Home
411 |         RCASE End:   gotoEOL();                  // End
412 |         RCASE PgUp:  gotoBlock(block-1);         // PgUp
413 |         RCASE PgDn:  gotoBlock(block+1);         // PgDn
414 |         RCASE Del:   edDelX('.');                // Delete
415 |         RCASE Ins:   toggleInsert();             // Insert
416 |         RCASE CHome: mv(-NUM_LINES, -NUM_COLS);  // <ctrl>-Home
417 |         RCASE CEnd:  mv(NUM_LINES, -NUM_COLS);   // <ctrl>-End
418 |         RCASE STab:  mv(0, -8);                  // <shift-tab>
419 |         RCASE F1: toCmd(); zType("-See Editor.md-"); // F1
420 |     }
421 | }
422 | 
423 | static int processEditorChar(int c) {
424 |     CursorOff();
425 |     if (!btwi(c,32,126)) { doCTL(c); return 1; }
426 |     if (btwi(edMode,INSERT,REPLACE)) { return doInsertReplace((char)c); }
427 | 
428 |     switch (c) {
429 |         BCASE ' ': mvRight();
430 |         BCASE '#': CLS(); isShow=1;
431 |         BCASE '$': gotoEOL();
432 |         BCASE '_': mv(0,-NUM_COLS);
433 |         BCASE '1': replaceChar(1,1,0);  // COMPILE
434 |         BCASE '2': replaceChar(2,1,0);  // DEFINE
435 |         BCASE '3': replaceChar(3,1,0);  // INTERP
436 |         BCASE '4': replaceChar(4,1,0);  // COMMENT
437 |         BCASE '+': gotoBlock(block+1);  // Next block
438 |         BCASE '-': gotoBlock(block-1);  // Prev block
439 |         BCASE '/': cmdFind();
440 |         BCASE ':': edCommand();
441 |         BCASE 'a': mvRight(); insertMode();
442 |         BCASE 'A': gotoEOL(); insertMode();
443 |         BCASE 'b': insertSpace(0);
444 |         BCASE 'B': insertSpace(1);
445 |         BCASE 'c': edDelX('.'); insertMode();
446 |         BCASE 'C': edDelX('$'); insertMode();
447 |         BCASE 'd': edDelX(0);
448 |         BCASE 'D': edDelX('$');
449 |         BCASE 'g': mv(-NUM_LINES,-NUM_COLS);
450 |         BCASE 'G': mv(NUM_LINES,-NUM_COLS);
451 |         BCASE 'h': mvLeft();
452 |         BCASE 'i': insertMode();
453 |         BCASE 'I': mv(0, -NUM_COLS); insertMode();
454 |         BCASE 'j': mvDown();
455 |         BCASE 'J': joinLines();
456 |         BCASE 'k': mvUp();
457 |         BCASE 'l': mvRight();
458 |         BCASE 'm': mv(4,0);
459 |         BCASE 'M': mv(-4,0);
460 |         BCASE 'n': doFind(1);
461 |         BCASE 'N': doFind(0);
462 |         BCASE 'o': mvNextLine(); insertLine(line, -1); insertMode();
463 |         BCASE 'O': insertLine(line, -1); insertMode();
464 |         BCASE 'P': insertLine(line, -1); putLine(line);
465 |         BCASE 'p': mvNextLine(); insertLine(line, -1); putLine(line);
466 |         BCASE 'Q': mv(0,-4);
467 |         BCASE 'q': mv(0,4);
468 |         BCASE 'r': replace1();
469 |         BCASE 'R': replaceMode();
470 |         BCASE 'S': gotoBlock(lastBlock);
471 |         BCASE 'w': moveWord(1);
472 |         BCASE 'W': moveWord(0);
473 |         BCASE 'x': edDelX(c);
474 |         BCASE 'X': edDelX(c);
475 |         BCASE 'Y': yankLine(line, yanked);
476 |         BCASE 'Z': edDelX(c);
477 |     }
478 |     return 1;
479 | }
480 | 
481 | static void showFind() {
482 |     if (findBuf[0] == 0) { return; }
483 |     FG(255); BG(19);
484 |     for (int r=0; r<NUM_LINES; r++) {
485 |         char *cp = &EDCH(r,0);
486 |         char c = cp[MAX_COL];
487 |         cp[MAX_COL] = 0;
488 |         int f = strFind(cp, findBuf, 0);
489 |         while (0 <= f) {
490 |             GotoXY(f+2, r+2);
491 |             zType(findBuf);
492 |             f = strFind(cp, findBuf, f+1);
493 |         }
494 |         cp[MAX_COL] = c;
495 |     }
496 |     BG(0);
497 | }
498 | 
499 | static void showFooter() {
500 |     const char *x[3] = { "-normal-","-insert-","-replace-" };
501 |     char ch = EDCH(line,off);
502 |     toFooter(); White();
503 |     zTypeF("Block# %03d%s", block, isDirty ? " *" : "");
504 |     if (edMode != NORMAL) { Red(); }
505 |     zTypeF(" %s", x[edMode-1]);
506 |     if (edMode != NORMAL) { White(); }
507 |     zTypeF(" (%d:%d - #%d/$%02x)", line+1, off+1, ch, ch);
508 |     ClearEOL();
509 | }
510 | 
511 | static void showEditor() {
512 |     if (!isShow) { return; }
513 |     isShow = 0;
514 |     showState(-1); GotoXY(1,1); Green(); topBottom();
515 |     for (int r=0; r<NUM_LINES; r++) {
516 |         zType("\r\n|"); showState(0);
517 |         char *cp = &EDCH(r,0);
518 |         for (int c=0; c<NUM_COLS; c++) {
519 |             char ch = *(cp++);
520 |             if (btwi(ch,1,4)) { showState(ch); }
521 |             emit(MAX(ch,32));
522 |         }
523 |         Green(); zType("|"); 
524 |     }
525 |     zType("\r\n"); topBottom();
526 |     showFind();
527 | }
528 | 
529 | void editBlock(cell blk) {
530 |     int tmp = fetchWC(BLKA);
531 |     if (tmp && (tmp != blk)) { lastBlock = tmp; }
532 |     if (lastBlock == 0) { lastBlock = blk; }
533 |     setBlock((int)blk);
534 |     line = off = 0;
535 |     CLS();
536 |     edRdBlk();
537 |     isShow = 1;
538 |     normalMode();
539 |     while (edMode != QUIT) {
540 |         showEditor();
541 |         showFooter();
542 |         showCursor();
543 |         edBuf[BLOCK_SZ-1]=0;
544 |         processEditorChar(edKey());
545 |     }
546 |     toCmd(); ClearEOL();
547 |     CursorOn(); White();
548 | }
549 | 
550 | #endif //  EDITOR
551 | 


--------------------------------------------------------------------------------
/file-pc.c:
--------------------------------------------------------------------------------
 1 | #include "c4.h"
 2 | 
 3 | // Support for files
 4 | cell inputFp, outputFp, fileStk[FSTK_SZ + 1];
 5 | static char fn[32];
 6 | int fileSp;
 7 | 
 8 | void filePush(cell fh) { if (fileSp < FSTK_SZ) { fileStk[++fileSp] = fh; } }
 9 | cell filePop() { return (0 < fileSp) ? fileStk[fileSp--] : 0; }
10 | char *blockFn(int blk) { sprintf(fn, "block-%03d.fth", blk); return fn; }
11 | 
12 | void fileInit() { fileSp = 0; inputFp = 0; }
13 | cell fileOpen(const char *name, const char *mode) { return (cell)fopen(name, mode); }
14 | void fileClose(cell fh) { fclose((FILE*)fh); }
15 | void fileDelete(const char *name) { remove(name); }
16 | cell fileRead(char *buf, int sz, cell fh) { return fread(buf, 1, sz, (FILE*)fh); }
17 | cell fileWrite(char *buf, int sz, cell fh) { return fwrite(buf, 1, sz, (FILE*)fh); }
18 | void blockLoad(int blk) { fileLoad(blockFn(blk)); }
19 | 
20 | void blockLoadNext(int blk) {
21 |     if (inputFp) { fileClose(inputFp); inputFp = 0; }
22 |     fileLoad(blockFn(blk));
23 |     if (inputFp == 0) { inputFp = filePop(); }
24 | }
25 | 
26 | int fileGets(char *buf, int sz, cell fh) {
27 |     buf[0] = 0;
28 |     if (fh == 0) { fh = (cell)stdin; }
29 |     if (fgets(buf, sz, (FILE*)fh) != buf) return 0;
30 |     return strLen(buf);
31 | }
32 | 
33 | void fileLoad(const char *name) {
34 |     cell fh = fileOpen(name, "rt");
35 |     if (fh == 0) { zTypeF("-[%s] not found-", name); return; }
36 |     if (inputFp) { filePush(inputFp); }
37 |     inputFp = fh;
38 | }
39 | 


--------------------------------------------------------------------------------
/makefile:
--------------------------------------------------------------------------------
 1 | ARCH ?= 32
 2 | CFLAGS = -O3 -m$(ARCH)
 3 | srcfiles := $(shell find . -name "*.c")
 4 | incfiles := $(shell find . -name "*.h")
 5 | 
 6 | c4: $(srcfiles) $(incfiles)
 7 | 	$(CC) $(CFLAGS) $(srcfiles) -o $@
 8 | 
 9 | run: c4
10 | 	./c4
11 | 
12 | clean:
13 | 	rm -f c4
14 | 
15 | test: c4
16 | 	./c4 block-200.fth
17 | 
18 | bin: c4
19 | 	cp -u -p c4 ~/bin/
20 | 


--------------------------------------------------------------------------------
/sys-load.c:
--------------------------------------------------------------------------------
  1 | #include "c4.h"
  2 | 
  3 | #ifndef _SYS_LOAD_
  4 | void sys_load() {
  5 |     fileLoad("block-000.fth");
  6 | }
  7 | #else
  8 | void sys_load() {
  9 |     outer(" \
 10 | ( Comments are free/built-in ) \
 11 | : \\ 0 >in @ c! ; immediate \
 12 | : ->memory memory + ; \
 13 | : ->code dup + ->memory ; \
 14 | : here  (here)  wc@ ; \
 15 | : last  (last)  @ ; \
 16 | : base@ base  wc@ ; \
 17 | : base! base  wc! ; \
 18 | : block@ (block) wc@ ; \
 19 | : block! (block) wc! ; \
 20 | : vhere (vhere) @ ; \
 21 | : allot (vhere) +! ; \
 22 | : 0sp  0 (dsp)  wc! ; \
 23 | : 0rsp 0 (rsp)  wc! ; \
 24 | : , here  dup 1+ (here) wc! wc! ; \
 25 | : v, vhere ! cell allot ; \
 26 | : vc, vhere c! 1 allot ; \
 27 | : const ( n-- )  addword lit, (exit) , ; \
 28 | : var ( n-- ) vhere const allot ; \
 29 | : val -1 const ; \
 30 | : (val) last  w@ 1+ ->code const ; \
 31 | : create vhere addword vhere lit, ; \
 32 | : does> (jmp) , r> , ; \
 33 | : begin here ; immediate \
 34 | : again (jmp)   , , ; immediate \
 35 | : while (jmpnz) , , ; immediate \
 36 | : until (jmpz)  , , ; immediate \
 37 | : -while (njmpnz) , , ; immediate \
 38 | : -until (njmpz)  , , ; immediate \
 39 | : -if (njmpz) , here 0 , ; immediate \
 40 | : if  (jmpz)  , here 0 , ; immediate \
 41 | : if0 (jmpnz) , here 0 , ; immediate \
 42 | : else (jmp) , here swap 0 , here swap wc! ; immediate \
 43 | : then here swap wc! ; immediate \
 44 | : hex     $10 base! ; \
 45 | : binary  %10 base! ; \
 46 | : decimal #10 base! ; \
 47 | : ?dup -if dup then ; \
 48 | : nip swap drop ;        : tuck swap over ; \
 49 | : 2dup over over ;       : 2drop drop drop ; \
 50 | : rot >r swap r> swap ;  : -rot swap >r swap r> ; \
 51 | : 0< 0 < ;            : 0> 0 > ; \
 52 | : <= > 0= ;           : >= < 0= ;      : <> = 0= ; \
 53 | : 2+ 1+ 1+ ; inline \
 54 | : 2* dup + ; inline \
 55 | : 2/ 2 / ;   inline \
 56 | : cells cell * ; inline \
 57 | : cell+ cell + ; inline \
 58 | : min ( a b--c ) 2dup > if swap then drop ; \
 59 | : max ( a b--c ) 2dup < if swap then drop ; \
 60 | : btwi ( n l h--f ) >r over >  swap r> >  or 0= ; \
 61 | : negate com 1+ ; \
 62 | : abs  dup 0< if negate then ; \
 63 | : mod /mod drop ; \
 64 | : execute ( a-- ) >r ; \
 65 | : atdrop adrop tdrop ; \
 66 | : a+   a@+ drop ; inline   : a-   a@- drop ; inline \
 67 | : c@a  a@  c@ ;   inline   : c!a  a@  c! ;   inline \
 68 | : c@a+ a@+ c@ ;   inline   : c!a+ a@+ c! ;   inline \
 69 | : c@a- a@- c@ ;   inline   : c!a- a@- c! ;   inline \
 70 | : b+   b@+ drop ; inline   : b-   b@- drop ; inline \
 71 | : c@b  b@  c@ ;   inline   : c!b  b@  c! ;   inline \
 72 | : c@b+ b@+ c@ ;   inline   : c!b+ b@+ c! ;   inline \
 73 | : c@b- b@- c@ ;   inline   : c!b- b@- c! ;   inline \
 74 | : t+   t@+ drop ; inline   : t-   t@- drop ; inline \
 75 | : c@t  t@  c@ ;   inline   : c!t  t@  c! ;   inline \
 76 | : c@t+ t@+ c@ ;   inline   : c!t+ t@+ c! ;   inline \
 77 | : c@t- t@- c@ ;   inline   : c!t- t@- c! ;   inline \
 78 | 100 var pad \
 79 | : <#   ( n1--n2 )  pad 99 + >t 0 t@ c! dup 0< >a abs ; \
 80 | : #c   ( c-- )     t- t@ c! ; \
 81 | : #.   ( -- )      '.' #c ; \
 82 | : #n   ( n-- )     dup 9 > if 7 + then '0' + #c ; \
 83 | : #    ( n1--n2 )  base@ /mod swap #n ; \
 84 | : #s   ( n-- )     begin # -while ; \
 85 | : #>   ( --str )   drop a> if '-' #c then t> ; \
 86 | : (.) <# #s #> ztype ; \
 87 | : . (.) 32 emit ; \
 88 | : bl 32 ; inline   : space 32 emit ; \
 89 | : cr 13 emit 10 emit ; \
 90 | : tab 9 emit ; \
 91 | : .version version <# # # #. # # #. #s #> ztype ; \
 92 | : ?  @ . ; \
 93 | : ed block@ edit ;  : ed! block! ; inline \
 94 | : .s '(' emit space (dsp) wc@ 1- ?dup \
 95 |     if for i 1+ cells dstk + @ . next then ')' emit ; \
 96 | : [[ vhere >t here >t 1 state wc! ; \
 97 | : ]] (exit) , 0 state wc! t@ (here) wc! t> >r t> (vhere) ! ; immediate \
 98 | mem-sz ->memory const mem-end \
 99 | : ->xt     w@ ; inline \
100 | : ->flags  wc-sz + c@ ; \
101 | : ->len    wc-sz + 1+ c@ ; \
102 | : ->name   wc-sz + 2+ ; \
103 | : words last >a 0 >t 0 >r \
104 |     begin \
105 |         a@ ->name ztype r@ 1+ r! \
106 |         a@ ->len dup 7 > t@ + t! 14 > t@ + t! \
107 |         t@+ 9 > if cr 0 t! else tab then \
108 |         a@ de-sz + a! a@ mem-end < \
109 |     while tdrop adrop r> .\"  (%d words)\" ; \
110 | : words-n ( n-- )  0 >a last swap for \
111 |             dup ->name ztype tab a@+ 9 > if cr 0 a! then de-sz + \
112 |         next drop adrop ; \
113 | cell var t0 cell var t1 \
114 | : marker here 20 wc!  last t0 !  vhere t1 ! ; \
115 | : forget 20 wc@ (here) wc! t0 @ (last) ! t1 @ (vhere) ! ; \
116 | : fgl last dup de-sz + (last) ! ->xt (here) wc! ; \
117 | : fopen-rt ( fn--fh|0 )  z\" rt\" fopen ; \
118 | : fopen-rb ( fn--fh|0 )  z\" rb\" fopen ; \
119 | : fopen-wb ( fn--fh|0 )  z\" wb\" fopen ; \
120 | : ->file ( fn-- ) fopen-wb (output-fp) ! ; \
121 | : ->stdout ( -- ) (output-fp) @ ?dup if fclose 0 (output-fp) ! then ; \
122 | : thru ( f t-- ) begin dup load 1- over over > until drop drop ; \
123 | marker \
124 | ");
125 | }
126 | #endif // _SYS_LOAD_
127 | 


--------------------------------------------------------------------------------
/system.c:
--------------------------------------------------------------------------------
 1 | #include "c4.h"
 2 | 
 3 | #ifdef IS_WINDOWS
 4 |   #include <conio.h>
 5 |   int qKey() { return _kbhit(); }
 6 |   int key() { return _getch(); }
 7 |   void ttyMode(int isRaw) {}
 8 | #endif
 9 | 
10 | #ifdef IS_LINUX
11 |   #include <termios.h>
12 |   #include <unistd.h>
13 |   #include <sys/time.h>
14 |   
15 |   void ttyMode(int isRaw) {
16 |       static struct termios origt, rawt;
17 |       static int curMode = -1;
18 |       if (curMode == -1) {
19 |           curMode = 0;
20 |           tcgetattr( STDIN_FILENO, &origt);
21 |           cfmakeraw(&rawt);
22 |       }
23 |       if (isRaw != curMode) {
24 |           if (isRaw) {
25 |               tcsetattr( STDIN_FILENO, TCSANOW, &rawt);
26 |           } else {
27 |               tcsetattr( STDIN_FILENO, TCSANOW, &origt);
28 |           }
29 |           curMode = isRaw;
30 |       }
31 |   }
32 |   int qKey() {
33 |       struct timeval tv;
34 |       fd_set rdfs;
35 |       ttyMode(1);
36 |       tv.tv_sec = 0;
37 |       tv.tv_usec = 0;
38 |       FD_ZERO(&rdfs);
39 |       FD_SET(STDIN_FILENO, &rdfs);
40 |       select(STDIN_FILENO+1, &rdfs, NULL, NULL, &tv);
41 |       int x = FD_ISSET(STDIN_FILENO, &rdfs);
42 |       return x;
43 |   }
44 |   int key() {
45 |       ttyMode(1);
46 |       int x = fgetc(stdin);
47 |       return x;
48 |   }
49 | #endif // IS_LINUX
50 | 
51 | cell timer() { return (cell)clock(); }
52 | void zType(const char *str) { fputs(str, outputFp ? (FILE*)outputFp : stdout); }
53 | void emit(const char ch) { fputc(ch, outputFp ? (FILE*)outputFp : stdout); }
54 | 
55 | // REP - Read/Execute/Print (no Loop)
56 | void REP() {
57 |     char tib[128];
58 | 	if (inputFp == 0) {
59 | 		ttyMode(0);
60 |         if (fetchWC(SA) == COMMENT) { changeState(INTERP); }
61 | 		ok();
62 | 	}
63 | 	if (fileGets(tib, sizeof(tib), inputFp)) {
64 | 		outer(tib);
65 | 		return;
66 | 	}
67 | 	if (inputFp == 0) { exit(0); }
68 | 	fileClose(inputFp);
69 | 	inputFp = filePop();
70 | }
71 | 
72 | void loadArgument(const char *arg) {
73 |     char fn[32];
74 |     strCpy(fn, arg);
75 |     cell tmp = fileOpen(fn, "rb");
76 |     if (tmp) {
77 |         if (inputFp) { filePush(tmp); }
78 |         else { inputFp = tmp;  }
79 |     }
80 | }
81 | 
82 | int main(int argc, char *argv[]) {
83 | 	c4Init();
84 |     if (argc > 1) { loadArgument(argv[1]); }
85 |     else { loadArgument("block-999.fth"); }
86 |     while (1) { REP(); };
87 | 	return 0;
88 | }
89 | 


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