├── .gdbinit ├── .gitignore ├── COPYING ├── GNUmakefile ├── README ├── app └── sokoban.fs ├── assembler.fs ├── blocks.fs ├── boot.S ├── colors.fs ├── core.fs ├── corestage2.fs ├── debugger.fs ├── disassem.fs ├── editor.fs ├── eulex.lds ├── exceptions.fs ├── forth.S ├── generate-builtin-files.sh ├── input.fs ├── interpreter.fs ├── kernel ├── console.fs ├── cpuid.fs ├── exceptions.fs ├── floppy.fs ├── interrupts.fs ├── irq.fs ├── keyboard.fs ├── multiboot.fs ├── serial.fs ├── speaker.fs ├── timer.fs └── video.fs ├── linedit.fs ├── lisp ├── core.lisp └── lisp.fs ├── math.fs ├── memory.fs ├── multiboot.h ├── output.fs ├── run-eulex.sh ├── string.fs ├── structures.fs ├── tests ├── base.fs ├── strings.fs ├── tests.fs └── tsuite.fs ├── tools.fs ├── user.fs └── vocabulary.fs /.gdbinit: -------------------------------------------------------------------------------- 1 | file eulex 2 | target remote localhost:1234 3 | 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.o 3 | *.d 4 | eulex 5 | BUILTIN-FILES.S 6 | /eulexrc.fs 7 | -------------------------------------------------------------------------------- /GNUmakefile: -------------------------------------------------------------------------------- 1 | # -*- makefile -*- 2 | # 3 | 4 | .PHONY: all clean dist. 5 | 6 | KERNEL=eulex 7 | 8 | all: $(KERNEL) 9 | 10 | LINKER_SCRIPT = eulex.lds 11 | 12 | CFLAGS = -fstrength-reduce -nostdinc -m32 -nostdlib -fno-builtin -nostartfiles -nodefaultlibs -I. -ggdb 13 | ASFLAGS = $(CFLAGS) -I. 14 | DEPEND_FLAGS=-MM 15 | LDFLAGS=-Wl,-T$(LINKER_SCRIPT) 16 | FORTH_SRC= \ 17 | core.fs \ 18 | corestage2.fs \ 19 | vocabulary.fs \ 20 | exceptions.fs \ 21 | output.fs \ 22 | string.fs \ 23 | math.fs \ 24 | tools.fs \ 25 | disassem.fs \ 26 | structures.fs \ 27 | interpreter.fs \ 28 | kernel/multiboot.fs \ 29 | kernel/cpuid.fs \ 30 | kernel/video.fs \ 31 | kernel/console.fs \ 32 | colors.fs \ 33 | kernel/interrupts.fs \ 34 | kernel/exceptions.fs \ 35 | kernel/irq.fs \ 36 | kernel/timer.fs \ 37 | kernel/floppy.fs \ 38 | kernel/keyboard.fs \ 39 | kernel/speaker.fs \ 40 | kernel/serial.fs \ 41 | blocks.fs \ 42 | editor.fs \ 43 | debugger.fs \ 44 | linedit.fs \ 45 | input.fs \ 46 | memory.fs \ 47 | user.fs \ 48 | assembler.fs \ 49 | eulexrc.fs \ 50 | lisp/lisp.fs \ 51 | app/sokoban.fs 52 | 53 | TESTING_SRC=tests/tests.fs \ 54 | tests/tsuite.fs \ 55 | tests/base.fs \ 56 | tests/strings.fs 57 | 58 | LISP_SRC=lisp/core.lisp 59 | 60 | ASM_SRC=boot.S forth.S 61 | 62 | SOURCES=$(ASM_SRC) 63 | HEADERS=multiboot.h 64 | 65 | OBJS = $(ASM_SRC:.S=.o) $(FORTH_SRC:.fs=.o) $(TESTING_SRC:.fs=.o) $(LISP_SRC:.lisp=.o) 66 | 67 | $(KERNEL): $(OBJS) $(LINKER_SCRIPT) 68 | $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $(OBJS) 69 | 70 | clean: 71 | -rm -f *.[do] kernel/*.[do] tests/*.[do] app/*.[do] lisp/*.[do] $(KERNEL) BUILTIN-FILES.S 72 | 73 | %.d: %.S GNUmakefile 74 | @$(CC) $(DEPEND_FLAGS) $(CPPFLAGS) $< > $@.tmp; \ 75 | sed 's,\($*\)\.o[ :]*,\1.o $@ : ,g' < $@.tmp > $@; \ 76 | rm -f $@.tmp 77 | 78 | %.o: %.fs 79 | objcopy -I binary -O elf32-i386 -Bi386 $< $@ 80 | %.o: %.lisp 81 | objcopy -I binary -O elf32-i386 -Bi386 $< $@ 82 | 83 | eulexrc.fs: 84 | echo "( Write your personal definitions in this file )" > $@ 85 | 86 | forth.S: BUILTIN-FILES.S 87 | BUILTIN-FILES.S: GNUmakefile 88 | sh ./generate-builtin-files.sh $(FORTH_SRC) $(TESTING_SRC) $(LISP_SRC) 89 | 90 | dist: 91 | git archive --format=tar --prefix=eulex/ HEAD | gzip > eulex.tar.gz 92 | 93 | 94 | # ifneq ($(MAKECMDGOALS),clean) 95 | # -include $(ASSEM_SRC:.S=.d) 96 | # endif 97 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Eulex 2 | ===== 3 | 4 | Eulex is a straightforward Forth implementation for i386 machines. 5 | 6 | It includes almost as much Forth as I know, as well as a barebone 7 | environment with the keyboard, terminal, timer and speaker support, 8 | necessary to provide some common Forth words. Indeed, it provides a 9 | convenient line editing emacs-like keybindings and completion. 10 | 11 | As always, a lot of features are missing. If you want to have some 12 | fun, consider to write some of them! 13 | 14 | 15 | History 16 | ------- 17 | 18 | Originally, this project came up in 2009. A fellow and I started to 19 | write an operating system. We were looking for a low level and easy to 20 | implement language, which was fun and allowed to hack the language 21 | itself, in order to incorporate it to that system, which we named 22 | Eulex. I discovered Forth, and I figured out that it was a good 23 | choice, as we wanted to recreate an old system. I set about writing an 24 | implementation for the specification Forth79 in assembler, initially 25 | on GNU/Linux and using the C library since it was a convenient way to 26 | work, meanwhile my fellow implemented a simple C kernel for Eulex that 27 | would house Forth. This implementation was never incorporated, 28 | however. 29 | 30 | Two years later, without other idea which in I could work, I took a 31 | primitive version of the C kernel of Eulex, and I used it as a thin 32 | compatibility layer to run the Forth implementation on the metal. Then, 33 | I made up my mind to write the whole system in Forth. So, Forth was 34 | ported to 32 bits and pieces of C code were rewritten in Forth. 35 | The C layer was an useful scaffolding, as it allowed not only to use 36 | modern tools for debugging, but build the system in the right order. 37 | Eventually, Forth replaced C and I could move the scaffolding away, 38 | removing the whole C code. As outcome of that, I share this barebone 39 | Forth system with you, with the hope that someone will have so much 40 | fun as I have had. 41 | 42 | Happy Hacking 43 | 44 | DVP 45 | -------------------------------------------------------------------------------- /assembler.fs: -------------------------------------------------------------------------------- 1 | \ assembler.fs --- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | vocabulary Assembler 21 | get-current 22 | also Assembler definitions 23 | 24 | DECIMAL 25 | 26 | \ Assembler output 27 | 28 | \ Cross-assembler: 29 | \ Difference between the dictionary pointer to the target address. 30 | 0 value target-offset 31 | : there here target-offset + ; 32 | 33 | : lb dup 255 and c, ; 34 | : 8>> 8 rshift ; 35 | 36 | : byte lb drop ; 37 | : word lb 8>> lb drop ; 38 | : dword lb 8>> lb 8>> lb 8>> lb drop ; 39 | 40 | 1 constant OP-AL 41 | 2 constant OP-AX 42 | 4 constant OP-EAX 43 | 8 constant OP-REG8 44 | 16 constant OP-REG16 45 | 32 constant OP-REG32 46 | 64 constant OP-SREG 47 | 128 constant OP-IMM 48 | 256 constant OP-MEM8 49 | 512 constant OP-MEM16 50 | 1024 constant OP-MEM32 51 | 52 | \ Registers 53 | 54 | : reg8 create , does> @ OP-REG8 swap ; 55 | : reg16 create , does> @ OP-REG16 swap ; 56 | : reg32 create , does> @ OP-REG32 swap ; 57 | : sreg create , does> @ OP-SREG swap ; 58 | 59 | : %al OP-AL OP-REG8 or 0 ; 60 | : %ax OP-AX OP-REG16 or 0 ; 61 | : %eax OP-EAX OP-REG32 or 0 ; 62 | 63 | ( 0 reg32 %eax 0 reg16 %ax 0 reg8 %al ) 0 sreg %es 64 | 1 reg32 %ecx 1 reg16 %cx 1 reg8 %cl 1 sreg %cs 65 | 2 reg32 %edx 2 reg16 %dx 2 reg8 %dl 2 sreg %ss 66 | 3 reg32 %ebx 3 reg16 %bx 3 reg8 %bl 3 sreg %ds 67 | 4 reg32 %esp 4 reg16 %sp 4 reg8 %ah 4 sreg %fs 68 | 5 reg32 %ebp 5 reg16 %bp 5 reg8 %ch 5 sreg %gs 69 | 6 reg32 %esi 6 reg16 %si 6 reg8 %dh 70 | 7 reg32 %edi 7 reg16 %di 7 reg8 %bh 71 | 72 | \ Immediate values 73 | : # OP-IMM swap ; 74 | 75 | 76 | \ Memory references 77 | 78 | \ The more general memory reference mode is 79 | \ 80 | \ base + index*scale + displacement 81 | \ 82 | \ where BASE and INDEX are 32bits registers, SCALE is 1, 2 or 4, and 83 | \ DISPLACEMENT is an immediate offset. 84 | \ 85 | \ The following variables contain each one of the parts in the general 86 | \ addressing mode. A value of -1 where a register is expected means 87 | \ that it is omitted. Note that is it not the ModR/M either SIB 88 | \ bytes. They are encoded later from this variables, however. 89 | variable base 90 | variable index 91 | variable scale 92 | variable displacement 93 | 94 | : reset-addressing-mode 95 | -1 base ! 96 | -1 index ! 97 | 1 scale ! 98 | 0 displacement ! ; 99 | 100 | : check-reg32 101 | over OP-REG32 and 0= 102 | abort" Addressing mode must use 32bits registers." ; 103 | 104 | : B check-reg32 base ! DROP ; 105 | : I check-reg32 index ! DROP ; 106 | : S scale ! ; 107 | : D displacement ! ; 108 | 109 | \ For addressing modes without base 110 | : #PTR8 D OP-MEM8 0 ; 111 | : #PTR16 D OP-MEM16 0 ; 112 | : #PTR32 D OP-MEM32 0 ; 113 | ' #PTR32 alias #PTR 114 | 115 | : 1* 1 S ; 116 | : 2* 2 S ; 117 | : 4* 4 S ; 118 | : 8* 8 S ; 119 | 120 | \ BASE BASE + DISP INDEX 121 | : [%eax] %eax B OP-MEM32 0 ; : +[%eax] D [%eax] ; : >%eax %eax I ; 122 | : [%ecx] %ecx B OP-MEM32 0 ; : +[%ecx] D [%ecx] ; : >%ecx %ecx I ; 123 | : [%edx] %edx B OP-MEM32 0 ; : +[%edx] D [%edx] ; : >%edx %edx I ; 124 | : [%ebx] %ebx B OP-MEM32 0 ; : +[%ebx] D [%ebx] ; : >%ebx %ebx I ; 125 | : [%esp] %esp B OP-MEM32 0 ; : +[%esp] D [%esp] ; ( %esp is not a valid index ) 126 | : [%ebp] %ebp B OP-MEM32 0 ; : +[%ebp] D [%ebp] ; : >%ebp %ebp I ; 127 | : [%esi] %esi B OP-MEM32 0 ; : +[%esi] D [%esi] ; : >%esi %esi I ; 128 | : [%edi] %edi B OP-MEM32 0 ; : +[%edi] D [%edi] ; : >%edi %edi I ; 129 | 130 | \ Override size of the memory reference 131 | : PTR8 NIP OP-MEM8 SWAP ; 132 | : PTR16 NIP OP-MEM16 SWAP ; 133 | : PTR32 NIP OP-MEM32 SWAP ; \ Default 134 | 135 | 136 | \ INSTRUCTION ENCODING 137 | 138 | \ Parts of the instruction and the size in bytes of them in the 139 | \ current instruction. A size of zero means this part is not present. 140 | variable inst-size-override? 141 | variable inst-opcode variable inst-opcode# 142 | variable inst-modr/m variable inst-modr/m# 143 | variable inst-sib variable inst-sib# 144 | variable inst-disp variable inst-disp# 145 | variable inst-imm variable inst-imm# 146 | 147 | : 0! 0 swap ! ; 148 | : 0F, $0F byte ; ( extended opcode ) 149 | : 66, $66 byte ; 150 | 151 | \ Initialize the assembler state for a new instruction. It must be 152 | \ called in the beginning of each instruction. 153 | : reset-instruction 154 | reset-addressing-mode 155 | inst-size-override? off 156 | inst-opcode 0! 1 inst-opcode# ! 157 | inst-modr/m 0! inst-modr/m# 0! 158 | inst-sib 0! inst-sib# 0! 159 | inst-disp 0! inst-disp# 0! 160 | inst-imm 0! inst-imm# 0! 161 | ; latestxt execute 162 | 163 | \ Words to fill instruction's data 164 | 165 | \ Set the size-override prefix. 166 | : size-override inst-size-override? on ; 167 | 168 | \ Set some bits in the opcode field. 169 | : |opcode ( u -- ) 170 | inst-opcode @ or inst-opcode ! ; 171 | 172 | : clear-bits ( mask value -- value* ) 173 | swap invert and ; 174 | 175 | : set-bits! ( x mask addr -- ) 176 | dup >r @ over swap clear-bits -rot and or r> ! ; 177 | 178 | : set-modr/m-bits! 179 | inst-modr/m set-bits! 180 | 1 inst-modr/m# ! ; 181 | 182 | : set-sib-bits! 183 | inst-sib set-bits! 184 | 1 inst-sib# ! ; 185 | 186 | : mod! 6 lshift %11000000 set-modr/m-bits! ; 187 | : op/reg! 3 lshift %00111000 set-modr/m-bits! ; 188 | : r/m! %00000111 set-modr/m-bits! ; 189 | 190 | : s! 6 lshift %11000000 set-sib-bits! ; 191 | : i! 3 lshift %00111000 set-sib-bits! ; 192 | : b! %00000111 set-sib-bits! ; 193 | 194 | \ Set the displacement field. 195 | : disp! inst-disp ! ; : disp#! inst-disp# ! ; 196 | : disp8! disp! 1 disp#! ; 197 | : disp32! disp! 4 disp#! ; 198 | 199 | \ Set the immediate field. 200 | : imm! inst-imm ! ; : imm#! inst-imm# ! ; 201 | 202 | : flush-value ( x size -- ) 203 | case 204 | 0 of drop endof 205 | 1 of byte endof 206 | 2 of word endof 207 | 4 of dword endof 208 | true abort" Invalid number of bytes." 209 | endcase ; 210 | 211 | : flush 212 | \ Prefixes 213 | inst-size-override? @ if 66, endif 214 | \ Opcode, modr/m and sib 215 | inst-opcode @ inst-opcode# @ flush-value 216 | inst-modr/m @ inst-modr/m# @ flush-value 217 | inst-sib @ inst-sib# @ flush-value 218 | \ Displacement and immediate 219 | inst-disp @ inst-disp# @ flush-value 220 | inst-imm @ inst-imm# @ flush-value 221 | reset-instruction ; 222 | 223 | 224 | \ MEMORY REFERENCE ENCODING 225 | 226 | : <=x<= ( n1 n2 n3 -- n1<=n2<=n3 ) 227 | over -rot <= >r <= r> and ; 228 | 229 | : 8-bit? ( n -- flag ) 230 | -128 swap 127 <=x<= ; 231 | 232 | \ return the mod value for a given displacement. 233 | : disp>mod ( n -- 0|1|2 ) 234 | ?dup 0= if 0 else 235 | 8-bit? if 1 else 2 then 236 | endif ; 237 | 238 | : scale>s ( scale -- s ) 239 | case 240 | 1 of 0 endof 241 | 2 of 1 endof 242 | 4 of 2 endof 243 | 8 of 3 endof 244 | true s" Bad scale value." 245 | endcase ; 246 | 247 | : null-displacement? displacement @ 0= ; 248 | 249 | \ Encode the displacement in the displacement field and the mod field 250 | \ of the modr/m byte. It is a general encoding which may be necessary 251 | \ to modify for special rules. 252 | : encode-displacement 253 | displacement @ dup disp>mod dup mod! 254 | case 255 | 0 of 0 disp#! drop endof 256 | 1 of 1 disp#! disp8! endof 257 | 2 of 4 disp#! disp32! endof 258 | endcase ; 259 | 260 | \ Encode memory references where there is not an index register. It 261 | \ covers memory references of the form BASE + DISP, where BASE and 262 | \ DISP are optional. 263 | : encode-non-indexed-mref 264 | scale @ 1 <> abort" Scaled memory reference without index." 265 | base @ -1 = if 266 | 5 r/m! displacement @ disp32! \ only displacement 267 | else 268 | encode-displacement 269 | \ Special case: the ModR/M byte cannot encode [%EBP] as it is 270 | \ used to encode `only displacement' memory references, so we 271 | \ force a 8bits zero displacement. 272 | %ebp nip base @ = null-displacement? and if 1 mod! 0 disp8! endif 273 | \ Encode the base register in the ModR/M byte. If it is %esp, 274 | \ it requires to include the SIB byte. 275 | base @ r/m! 276 | \ NOTE: 4 means no index in SIB. 277 | %esp nip base @ = if base @ B! 4 I! endif 278 | endif ; 279 | 280 | \ Encode memory references with an index register. It is encoded to 281 | \ the SIB byte generally. 282 | : encode-indexed-mref 283 | base @ -1 = if 284 | \ Special case: INDEX*SCALE + DISP. If SCALE is 1, we can 285 | \ encode the memory reference as a non-indexed. Otherwise, we 286 | \ have to force disp to 32bits. 287 | scale @ 1 = if 288 | index @ base ! -1 index ! encode-non-indexed-mref 289 | else 290 | 0 mod! 4 r/m! 291 | scale @ scale>s s! index @ I! 5 B! 292 | displacement @ disp32! 293 | endif 294 | else 295 | \ More general addressing mode. We write R/M to 4 to specify a 296 | \ SIB byte, and write scale, index and base to it. 297 | encode-displacement 4 r/m! 298 | scale @ scale>s s! index @ i! base @ b! 299 | endif ; 300 | 301 | \ Encode a general memory reference from the variables BASE, INDEX, 302 | \ SCALE and DISPLACEMENT to the current instruction. 303 | : encode-mref 304 | index @ -1 = if 305 | encode-non-indexed-mref 306 | else 307 | encode-indexed-mref 308 | endif ; 309 | 310 | 311 | \ INSTRUCTION-DEFINING WORDS 312 | 313 | \ Operands Pattern-maching 314 | variable inst#op 315 | 316 | : operands inst#op ! ; 317 | ' operands alias operand 318 | 319 | : 2ops? inst#op @ 2 = ; 320 | 321 | : 1-op-match ( op mask -- op flag ) 322 | 2 pick and 0<> ; 323 | 324 | : 2-op-match ( op1 op2 mask1 mask2 -- op1 op2 flag ) 325 | 3 pick and 0<> swap 326 | 5 pick and 0<> and ; 327 | 328 | : op-match ( ops .. masks ... -- ops .. flag ) 329 | inst#op @ 1 = if 1-op-match else 2-op-match then ; 330 | 331 | \ Patterns 332 | ' OP-AL alias al 333 | ' OP-AX alias ax 334 | ' OP-EAX alias eax 335 | ' OP-REG8 alias reg8 336 | ' OP-REG16 alias reg16 337 | ' OP-REG32 alias reg32 338 | ' OP-SREG alias sreg 339 | ' OP-IMM alias imm 340 | ' OP-MEM8 alias mem8 341 | ' OP-MEM16 alias mem16 342 | ' OP-MEM32 alias mem32 343 | \ Multi-patterns 344 | -1 constant any 345 | al ax or eax or constant acc 346 | reg8 reg16 or reg32 or constant reg 347 | mem8 mem16 or mem32 or constant mem 348 | reg8 mem8 or constant r/m8 349 | reg16 mem16 or constant r/m16 350 | reg32 mem32 or constant r/m32 351 | reg mem or constant r/m 352 | \ any? matches with any type if the current instruction has 2 353 | \ operands. Otherwise it is ignored. 354 | : any? 2ops? if any then ; 355 | 356 | : (no-dispatch) 357 | reset-instruction 358 | true abort" The instruction does not support these operands." ; 359 | 360 | 0 constant begin-dispatch immediate 361 | 362 | : ` postpone postpone ; immediate 363 | 364 | : dispatch: 365 | 1+ >r 366 | ` op-match ` if 367 | r> 368 | ; immediate compile-only 369 | 370 | : :: 371 | >r ` else r> 372 | ; immediate compile-only 373 | 374 | : end-dispatch 375 | ` (no-dispatch) 376 | 0 ?do ` then loop 377 | ; immediate compile-only 378 | 379 | \ Encode some pieces of the instruction automatically. 380 | 381 | \ Set size-override prefix if some of the operands is a r/m16. 382 | : size-override? 383 | begin-dispatch 384 | any? r/m16 dispatch: size-override :: 385 | r/m16 any? dispatch: size-override :: 386 | exit 387 | end-dispatch ; 388 | 389 | \ Encode both memory references and immediate (if there) to the ModR/M 390 | \ byte and the Immediate field, respectively. 391 | : encode-memory 392 | begin-dispatch 393 | mem any? dispatch: encode-mref :: 394 | any? mem dispatch: encode-mref :: 395 | exit 396 | end-dispatch ; 397 | 398 | : encode-immediate-size 399 | \ NOTE: This is done automatically only if the instruction has 400 | \ _TWO_ operands. In which case, the size will match the size of 401 | \ the target operand. Instructions with 1 operand have to handle 402 | \ the immediate by themselves. 403 | 2ops? if 404 | begin-dispatch 405 | imm r/m8 dispatch: 1 imm#! :: 406 | imm r/m16 dispatch: 2 imm#! :: 407 | imm r/m32 dispatch: 4 imm#! :: 408 | exit 409 | end-dispatch 410 | endif ; 411 | 412 | \ This word can be called in the beginning of an instruction to encode 413 | \ so much as we can automatically. 414 | : instruction 415 | size-override? encode-memory encode-immediate-size ; 416 | 417 | \ Check that the size of both operands is the same or signal an error. 418 | : same-size 419 | begin-dispatch 420 | imm any dispatch: :: 421 | r/m8 r/m8 dispatch: :: 422 | r/m16 r/m16 dispatch: :: 423 | r/m32 r/m32 dispatch: :: 424 | true abort" The size of the operands must match." 425 | end-dispatch ; 426 | 427 | : immediate-operand 1 operand 428 | begin-dispatch 429 | imm dispatch: :: 430 | end-dispatch ; 431 | 432 | \ Define an instruction with no operands 433 | : single-instruction ( opcode -- ) 434 | create c, does> 0 operands @ |opcode flush ; 435 | 436 | : >reg op/reg! drop ; 437 | : >opcode |opcode drop ; 438 | : >imm imm! drop ; 439 | : >imm8 >imm 1 imm#! ; 440 | : >imm16 >imm 2 imm#! ; 441 | : >imm32 >imm 4 imm#! ; 442 | 443 | : >r/m 444 | inst#op @ >r 445 | 1 operand begin-dispatch 446 | reg dispatch: 3 mod! r/m! drop :: 447 | mem dispatch: 2drop :: 448 | end-dispatch 449 | r> operands ; 450 | 451 | : size-bit 452 | begin-dispatch 453 | any? r/m8 dispatch: 0 :: 454 | any? r/m16 dispatch: 1 :: 455 | any? r/m32 dispatch: 1 :: 456 | end-dispatch ; 457 | 458 | : direction-bit 459 | begin-dispatch 460 | reg r/m dispatch: 0 :: 461 | r/m reg dispatch: 1 :: 462 | end-dispatch ; 463 | 464 | : sign-extend-bit 465 | begin-dispatch 466 | imm r/m8 dispatch: 0 :: 467 | imm r/m dispatch: 468 | 2swap dup >r 2swap r> 469 | 8-bit? if 1 else 0 then :: 470 | end-dispatch ; 471 | 472 | \ Set opcode and size bit. 473 | : opcode-w |opcode size-bit |opcode ; 474 | : opcode-wxxx |opcode size-bit 3 lshift |opcode ; 475 | : opcode-dw opcode-w direction-bit 2 * |opcode ; 476 | : opcode-sw opcode-w sign-extend-bit if 2 |opcode 1 imm#! endif ; 477 | 478 | \ Generic 2 operand instructions. 479 | : inst-imm-r/m opcode-w >r/m >imm ; 480 | : inst-reg-reg opcode-w >r/m >reg ; 481 | : inst-reg-r/m opcode-dw 482 | begin-dispatch 483 | reg r/m dispatch: >r/m >reg :: 484 | r/m reg dispatch: >reg >r/m :: 485 | end-dispatch ; 486 | 487 | 488 | \ ------------------------------------------------------------------------- 489 | 490 | : ascii" 491 | [char] " parse dup byte 492 | here swap move ; 493 | 494 | 495 | \ Arithmetic 496 | 497 | : inst-imm-acc 498 | opcode-w 4 |opcode 2drop >imm ; 499 | 500 | : arith-imm-r/m ( opext -- ) 501 | >r $80 opcode-sw >r/m >imm r> op/reg! ; 502 | 503 | : inst-binary-arithm ( opcode op-extension -- ) 504 | 2>r 505 | 2 operands same-size instruction 506 | begin-dispatch 507 | imm acc dispatch: 508 | \ Here, you can encode as imm-r/m or imm-acc. We choose the 509 | \ shorter according to the size of the immediate value. 510 | sign-extend-bit if 511 | 2r> nip arith-imm-r/m 512 | else 513 | 2r> drop inst-imm-acc 514 | then :: 515 | imm r/m dispatch: 2r> nip arith-imm-r/m :: 516 | reg reg dispatch: 2r> drop inst-reg-reg :: 517 | r/m r/m dispatch: 2r> drop inst-reg-r/m :: 518 | end-dispatch 519 | flush ; 520 | 521 | : adc $10 %010 inst-binary-arithm ; 522 | : add $00 %000 inst-binary-arithm ; 523 | : and $20 %100 inst-binary-arithm ; 524 | : cmp $38 %111 inst-binary-arithm ; 525 | : or $08 %001 inst-binary-arithm ; 526 | : sbb $18 %011 inst-binary-arithm ; 527 | : sub $28 %101 inst-binary-arithm ; 528 | : xor $30 %110 inst-binary-arithm ; 529 | 530 | : inst-unary-arithm ( ext ) 531 | >r 1 operand instruction 532 | begin-dispatch 533 | r/m dispatch: $F6 opcode-w >r/m r> op/reg! :: 534 | end-dispatch 535 | flush ; 536 | 537 | : div %110 inst-unary-arithm ; 538 | : idiv %111 inst-unary-arithm ; 539 | : imul %101 inst-unary-arithm ; \ Binary version is not supported. 540 | : mul %100 inst-unary-arithm ; 541 | : neg %011 inst-unary-arithm ; 542 | : not %010 inst-unary-arithm ; 543 | 544 | : inc 1 operand instruction 545 | begin-dispatch 546 | reg8 mem or dispatch: $FE opcode-w >r/m :: 547 | reg dispatch: $40 |opcode >opcode :: 548 | end-dispatch 549 | flush ; 550 | 551 | : dec 1 operand instruction 552 | begin-dispatch 553 | reg8 mem or dispatch: $FE opcode-w >r/m 1 op/reg! :: 554 | reg dispatch: $48 |opcode >opcode :: 555 | end-dispatch 556 | flush ; 557 | 558 | 559 | \ Shift 560 | 561 | : inst-shift/rotate ( extension -- ) op/reg! 562 | 2 operands instruction 563 | begin-dispatch 564 | imm r/m dispatch: 565 | $C0 opcode-w >r/m dup 1 = if 566 | $10 |opcode 2drop 567 | else 568 | >imm8 569 | then :: 570 | reg8 r/m dispatch: 571 | $D2 opcode-w >r/m 572 | nip %cl nip <> abort" The source register must be %cl." :: 573 | end-dispatch 574 | flush ; 575 | 576 | : rol %000 inst-shift/rotate ; 577 | : ror %001 inst-shift/rotate ; 578 | : shl %100 inst-shift/rotate ; 579 | : shr %101 inst-shift/rotate ; 580 | 581 | \ MOVement instructions 582 | 583 | ( This variant encode the register in the opcode. Used by MOV) 584 | : inst-imm-reg* opcode-wxxx >opcode >imm ; 585 | 586 | : mov 2 operands instruction 587 | begin-dispatch 588 | \ Segment registers 589 | r/m sreg dispatch: $8E |opcode >reg >r/m :: 590 | sreg r/m dispatch: $8C |opcode >r/m >reg :: 591 | \ General purpose registers 592 | SAME-SIZE 593 | imm reg dispatch: $B0 inst-imm-reg* :: 594 | imm mem dispatch: $C6 inst-imm-r/m :: 595 | reg reg dispatch: $88 inst-reg-reg :: 596 | r/m r/m dispatch: $88 inst-reg-r/m :: 597 | end-dispatch 598 | flush ; 599 | 600 | : movs 2 operands encode-memory 601 | begin-dispatch 602 | r/m8 reg16 dispatch: 66, 0F, $BE |opcode >reg >r/m :: 603 | r/m8 reg32 dispatch: 0F, $BE |opcode >reg >r/m :: 604 | r/m16 reg32 dispatch: 0F, $BF |opcode >reg >r/m :: 605 | end-dispatch 606 | flush ; 607 | 608 | : movz 2 operands encode-memory 609 | begin-dispatch 610 | r/m8 reg16 dispatch: 66, 0F, $B6 |opcode >reg >r/m :: 611 | r/m8 reg32 dispatch: 0F, $B6 |opcode >reg >r/m :: 612 | r/m16 reg32 dispatch: 0F, $B7 |opcode >reg >r/m :: 613 | end-dispatch 614 | flush ; 615 | 616 | 617 | \ Branching 618 | 619 | : short-jump? ( target -- flag ) 620 | there 2 + - 8-bit? ; 621 | 622 | : rel8 there 2 + - >imm8 ; 623 | : rel32 there 5 + - >imm32 ; 624 | 625 | \ Base implementation for conditional jumps. 626 | 627 | : inst-short-jcc ( target tttn -- ) 628 | $70 |opcode |opcode rel8 flush ; 629 | : inst-long-jcc ( target tttn -- ) 630 | 0F, $80 |opcode |opcode rel32 flush ; 631 | 632 | : inst-jcc ( tttn -- ) >r immediate-operand instruction r> 633 | over short-jump? if inst-short-jcc else inst-long-jcc endif ; 634 | 635 | : jo %0000 inst-jcc ; : jno %0001 inst-jcc ; 636 | : jb %0010 inst-jcc ; : jnb %0011 inst-jcc ; 637 | ' jb alias jnae ' jnb alias jae 638 | : je %0100 inst-jcc ; : jne %0101 inst-jcc ; 639 | ' je alias jz ' jne alias jnz 640 | : jbe %0110 inst-jcc ; : jnbe %0111 inst-jcc ; 641 | ' jbe alias jna ' jnbe alias ja 642 | : js %1000 inst-jcc ; : jns %1001 inst-jcc ; 643 | : jp %1010 inst-jcc ; : jnp %1011 inst-jcc ; 644 | ' jp alias jpe ' jnp alias jpo 645 | : jl %1100 inst-jcc ; : jnl %1101 inst-jcc ; 646 | ' jl alias jnge ' jnl alias jge 647 | : jle %1110 inst-jcc ; : jnle %1111 inst-jcc ; 648 | ' jle alias jng ' jnle alias jg 649 | 650 | \ Unconditional jump 651 | : jmp 1 operand instruction 652 | begin-dispatch 653 | imm dispatch: $E9 |opcode 654 | dup short-jump? if rel8 2 |opcode else rel32 endif :: 655 | r/m dispatch: $FF |opcode 4 op/reg! >r/m :: 656 | end-dispatch 657 | flush ; 658 | 659 | : ljmp ( selector imm ) 2 operands 660 | begin-dispatch 661 | imm imm dispatch: $EA |opcode >imm32 flush word drop :: 662 | end-dispatch ; 663 | 664 | 665 | \ Input and output 666 | 667 | : in 2 operands 668 | begin-dispatch 669 | imm acc dispatch: $E4 opcode-w 2drop >imm8 :: 670 | reg16 acc dispatch: 671 | $EC opcode-w 2drop 672 | %dx nip <> abort" The source operand must be DX" drop :: 673 | end-dispatch 674 | flush ; 675 | 676 | : output 2 operands 677 | begin-dispatch 678 | imm acc dispatch: $E6 opcode-w 2drop >imm8 :: 679 | reg16 acc dispatch: 680 | $EE opcode-w 2drop 681 | %dx nip <> abort" The source operand must be DX" drop :: 682 | end-dispatch 683 | flush ; 684 | 685 | 686 | \ Other instructions 687 | 688 | : call 1 operand instruction 689 | begin-dispatch 690 | imm dispatch: $E8 |opcode there 5 + - >imm32 :: 691 | r/m dispatch: $FF |opcode 2 op/reg! >r/m :: 692 | end-dispatch 693 | flush ; 694 | 695 | : pop 1 operand instruction 696 | \ TODO: Support for segment registers 697 | begin-dispatch 698 | reg32 dispatch: $58 |opcode >opcode :: 699 | r/m dispatch: $8F |opcode >r/m :: 700 | end-dispatch 701 | flush ; 702 | 703 | : push 1 operand instruction 704 | begin-dispatch 705 | imm dispatch: $68 |opcode 706 | dup 8-bit? if 2 |opcode >imm8 else >imm32 endif :: 707 | r/m8 dispatch: (no-dispatch) :: 708 | reg dispatch: $50 |opcode >opcode :: 709 | r/m dispatch: $FF |opcode >r/m 6 op/reg! :: 710 | end-dispatch 711 | flush ; 712 | 713 | : lgdt 1 operand 714 | begin-dispatch 715 | r/m32 dispatch: 0F, $01 |opcode >r/m 2 op/reg! :: 716 | end-dispatch 717 | flush ; 718 | 719 | : lidt 1 operand 720 | begin-dispatch 721 | r/m32 dispatch: 0F, $01 |opcode >r/m 3 op/reg! :: 722 | end-dispatch 723 | flush ; 724 | 725 | $94 single-instruction cbw 726 | $99 single-instruction cdq 727 | 728 | $F4 single-instruction clc 729 | $FC single-instruction cld 730 | $FA single-instruction cli 731 | 732 | : cpuid 0F, $A2 |opcode flush ; 733 | 734 | $F4 single-instruction hlt 735 | $CF single-instruction iret 736 | 737 | $90 single-instruction nop 738 | 739 | $61 single-instruction popa 740 | $9D single-instruction popf 741 | $60 single-instruction pusha 742 | $9C single-instruction pushf 743 | 744 | $C3 single-instruction ret 745 | 746 | $FB single-instruction sti 747 | 748 | 749 | SET-CURRENT 750 | PREVIOUS 751 | 752 | 753 | \ Local Variables: 754 | \ forth-local-words: ((("begin-dispatch" "end-dispatch" "dispatch:" "::") 755 | \ compile-only (font-lock-keyword-face . 2)) 756 | \ (("single-instruction") immediate (font-lock-keyword-face . 2))) 757 | \ End: 758 | 759 | \ assembler.fs ends here 760 | -------------------------------------------------------------------------------- /blocks.fs: -------------------------------------------------------------------------------- 1 | \ blocks.fs -- 2 | 3 | \ Copyright 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ TODO: Support more than a single buffer 21 | 22 | require @kernel/floppy.fs 23 | require @memory.fs 24 | require @structures.fs 25 | 26 | defer read-block-from-backend 27 | defer write-block-to-backend 28 | defer block-buffer 29 | 30 | :noname -100 throw ; is read-block-from-backend 31 | :noname -100 throw ; is write-block-to-backend 32 | 33 | variable current-block 34 | -1 current-block ! 35 | 36 | variable block-updated? 37 | 38 | : update block-updated? on ; 39 | : updated? block-updated? @ ; 40 | 41 | : flush 42 | updated? if 43 | current-block @ write-block-to-backend 44 | block-updated? off 45 | endif ; 46 | 47 | : block ( u -- addr ) 48 | dup -1 = if -100 throw then 49 | dup current-block @ = if drop else 50 | flush dup current-block ! 51 | read-block-from-backend 52 | endif 53 | block-buffer ; 54 | 55 | : buffer ( u -- addr ) 56 | dup -1 = if -100 throw then 57 | dup current-block @ = if drop else 58 | flush current-block ! 59 | endif 60 | block-buffer ; 61 | 62 | 63 | variable scr 64 | 65 | : .2 dup 10 < if space then . ; 66 | 67 | : list ( u -- ) 68 | dup scr ! block 69 | 16 0 ?do cr i .2 dup 64 -trailing type 64 + loop 70 | drop ; 71 | 72 | ' flush alias save-buffers 73 | 74 | \ Floppy backend 75 | 76 | : read-block-from-floppy ( u -- ) 77 | 2* lba 2 read-sectors ; 78 | 79 | : write-block-to-floppy ( u -- ) 80 | 2* lba 2 write-sectors ; 81 | 82 | : use-floppy 83 | flush 84 | detect-drive not if -100 throw then 85 | ['] read-block-from-floppy is read-block-from-backend 86 | ['] write-block-to-floppy is write-block-to-backend 87 | ['] floppy-buffer is block-buffer ; 88 | 89 | \ Memory backend 90 | 91 | create memblock-buffer 1024 cells allot 92 | variable memblock-index 93 | variable #memblocks 94 | 95 | : &memblock ( u -- addr ) 96 | cells memblock-index @ + ; 97 | 98 | : allocate-memblock ( u -- addr ) 99 | 1024 allocate throw tuck swap &memblock ! ; 100 | 101 | : check-valid-memblock 102 | 0 over #memblocks @ between not if -101 throw then ; 103 | 104 | : read-block-from-memory ( u -- ) 105 | check-valid-memblock 106 | dup &memblock @ ?dup if nip else allocate-memblock then 107 | memblock-buffer 1024 move ; 108 | 109 | : write-block-to-memory ( u -- ) 110 | check-valid-memblock 111 | memblock-buffer swap &memblock @ 1024 move ; 112 | 113 | 114 | : use-memory flush 115 | heap-size 1024 u/ #memblocks ! 116 | #memblocks @ cells allocate throw memblock-index ! 117 | memblock-index @ #memblocks @ cells 0 fill 118 | ['] read-block-from-memory is read-block-from-backend 119 | ['] write-block-to-memory is write-block-to-backend 120 | ['] memblock-buffer is block-buffer ; 121 | 122 | \ blocks.fs ends here 123 | -------------------------------------------------------------------------------- /boot.S: -------------------------------------------------------------------------------- 1 | /* boot.S - bootstrap the kernel */ 2 | /* Copyright (C) 1999, 2001 Free Software Foundation, Inc. 3 | 4 | This program is free software; you can redistribute it and/or modify 5 | it under the terms of the GNU General Public License as published by 6 | the Free Software Foundation; either version 2 of the License, or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ 17 | 18 | #define ASM 1 19 | #include "multiboot.h" 20 | 21 | .section .text 22 | .globl start, _start 23 | start: 24 | _start: 25 | jmp multiboot_entry 26 | 27 | /* Align 32 bits boundary. */ 28 | .align 4 29 | 30 | /* Multiboot header. */ 31 | multiboot_header: 32 | /* magic */ 33 | .long MULTIBOOT_HEADER_MAGIC 34 | /* flags */ 35 | .long MULTIBOOT_HEADER_FLAGS 36 | /* checksum */ 37 | .long -(MULTIBOOT_HEADER_MAGIC + MULTIBOOT_HEADER_FLAGS) 38 | #ifndef __ELF__ 39 | /* header_addr */ 40 | .long multiboot_header 41 | /* load_addr */ 42 | .long _start 43 | /* load_end_addr */ 44 | .long _edata 45 | /* bss_end_addr */ 46 | .long _end 47 | /* entry_addr */ 48 | .long multiboot_entry 49 | #endif /* ! __ELF__ */ 50 | 51 | multiboot_entry: 52 | /* Initialize the stack pointer. */ 53 | movl $(stack + STACK_SIZE), %esp 54 | /* Reset EFLAGS. */ 55 | pushl $0 56 | popf 57 | /* Now enter the C main function... */ 58 | call run_forth 59 | loop: hlt 60 | jmp loop 61 | 62 | /* Our stack area. */ 63 | .comm stack, STACK_SIZE 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /colors.fs: -------------------------------------------------------------------------------- 1 | \ colors.fs --- 2 | 3 | \ Copyright 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ Examples of usage: 21 | 22 | : fg attr $0f and ; 23 | : bg attr $70 and ; 24 | 25 | : fg! attr [ $0f invert ]L and or attr! ; 26 | : bg! 4 lshift attr [ $70 invert ]L and or attr! ; 27 | 28 | : blink attr $80 or attr! ; 29 | : noblink attr [ $80 invert ]L and attr! ; 30 | 31 | variable light-level 32 | variable background? 33 | 34 | : color create , does> @ 35 | light-level @ 0 > if 8 or endif 36 | background? @ if bg! else fg! endif 37 | background? off 38 | light-level 0! ; 39 | 40 | : upon background? on ; 41 | 42 | 0 color black 43 | 1 color blue 44 | 2 color green 45 | 3 color cyan 46 | 4 color red 47 | 5 color purple 48 | 6 color brown 49 | 7 color gray* 50 | 51 | : light light-level 1+! ; 52 | : dark light-level 1-! ; 53 | 54 | : gray 55 | 0 light-level @ < if dark gray* else light black then ; 56 | 57 | : yellow light brown ; 58 | : white light gray* ; 59 | : magenta light purple ; 60 | 61 | \ colors.fs ends here 62 | -------------------------------------------------------------------------------- /core.fs: -------------------------------------------------------------------------------- 1 | ( core.fs --- Basic definitions ) 2 | 3 | \ Copyright 2011, 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | : dp-limit 4193404 dp-base + ; 21 | : noop ; 22 | : chars ; 23 | : char+ 1 chars + ; 24 | : cell 4 ; 25 | : cells cell * ; 26 | : cell+ 1 cells + ; 27 | : here dp ; 28 | : allot dp + dp! ; 29 | : , here cell allot ! ; 30 | : c, here 1 allot c! ; 31 | : false 0 ; 32 | : true -1 ; 33 | : on true swap ! ; 34 | : off false swap ! ; 35 | 36 | : 0< 0 < ; 37 | : 0= 0 = ; 38 | : 0> 0 > ; 39 | : 1+ 1 + ; 40 | : 1- 1 - ; 41 | : 2+ 2 + ; 42 | : 2- 2 - ; 43 | : negate 0 swap - ; 44 | : not 0= ; 45 | : <= > not ; 46 | : >= < not ; 47 | : <> = not ; 48 | : u>= u< not ; 49 | : u<= u> not ; 50 | : 0<> 0 <> ; 51 | : 0! 0 swap ! ; 52 | : +! dup @ rot + swap ! ; 53 | : 1+! 1 swap +! ; 54 | : 1-! -1 swap +! ; 55 | : and! dup @ rot and swap ! ; 56 | : or! dup @ rot or swap ! ; 57 | 58 | : between ( a b c -- a<=b<=c ) 59 | over u>= >r u<= r> and ; 60 | 61 | : bit? ( x n -- flag ) 62 | 1 swap lshift and 0<> ; 63 | : CF? ( -- flag ) 64 | eflags 0 bit? ; 65 | : SF? ( -- flag) 66 | eflags 7 bit? ; 67 | : OF? ( -- flag ) 68 | eflags 11 bit? ; 69 | 70 | : -rot rot rot ; 71 | : tuck swap over ; 72 | : 2dup over over ; 73 | : 2drop drop drop ; 74 | : 2swap >r -rot r> -rot ; 75 | : 2nip 2>r 2drop 2r> ; 76 | 77 | : /mod 2dup / >r mod r> ; 78 | 79 | : aligned ( c-addr -- a-addr ) 80 | %11 + %11 invert and ; 81 | 82 | : 2aligned ( u -- u* ) 83 | %111 + %111 invert and ; 84 | 85 | : align dp aligned dp! ; 86 | : 2align dp 2aligned dp! ; 87 | 88 | : clearstack sp-limit sp! ; 89 | : depth sp-limit sp - cell / 1- ; 90 | 91 | \ Dictionary's entries (name token -- NT ) 92 | 93 | : nt>cname ( nop ) ; 94 | 95 | \ Get the NT of the last-defined word. 96 | : nt>name ( nt -- addr u ) 97 | nt>cname dup c@ swap 1+ swap ; 98 | : previous-word 99 | cell - @ ; 100 | 101 | : nt>flags ( nt -- flags ) 102 | dup c@ + 1+ ; 103 | : nt>cfa 104 | nt>flags 1+ ; 105 | : nt>pfa 106 | nt>cfa cell + ; 107 | : nt>xt 108 | nt>cfa @ ; 109 | 110 | : latest 111 | latest_word @ ; 112 | : latestxt 113 | latest nt>xt ; 114 | : immediate? ( word -- flag ) 115 | nt>flags c@ 1 and ; 116 | : cfa! ( xt -- ) 117 | latest nt>cfa ! ; 118 | : immediate 119 | latest nt>flags 1 swap or! ; 120 | : compile-only 121 | latest nt>flags 2 swap or! ; 122 | 123 | : [ 0 state ! ; immediate 124 | : ] 1 state ! ; 125 | 126 | : parse-nt 127 | parse-cname find-cname ; 128 | 129 | : nt>comp 130 | dup immediate? swap nt>xt ; 131 | 132 | : comp' 133 | parse-nt nt>comp ; 134 | 135 | : ' 136 | comp' nip ; 137 | 138 | : ) ; immediate 139 | 140 | ( Skip page breaks. They can be beautiful as section delimiters ) 141 | : 142 | 143 | ; immediate 144 | 145 | 146 | \ Code generation 147 | 148 | : push 149 | $83 c, $EE c, $04 c, \ subl $4, %esi 150 | $c7 c, $06 c, ( ... ) \ mov $..., (%esi) 151 | ; compile-only 152 | 153 | : rcall 154 | $e8 c, \ call 155 | ; compile-only 156 | 157 | : branch 158 | $e9 c, \ jmp 159 | ; compile-only 160 | 161 | : 0branch 162 | $8b c, $06 c, \ movl (%esi), %eax 163 | $83 c, $c6 c, $04 c, \ addl $4, %esi 164 | $85 c, $c0 c, \ test %eax, %eax 165 | $0f c, $84 c, \ jz [ELSE] 166 | ; compile-only 167 | 168 | : ?branch 169 | $8b c, $06 c, \ movl (%esi), %eax 170 | $83 c, $c6 c, $04 c, \ addl $4, %esi 171 | $85 c, $c0 c, \ test %eax, %eax 172 | $0f c, $85 c, \ jnz [ELSE] 173 | ; compile-only 174 | 175 | : return 176 | $c3 c, \ ret 177 | ; compile-only 178 | 179 | : return, $c3 c, ; 180 | 181 | : nop 182 | $90 c, \ nop 183 | ; compile-only 184 | 185 | 186 | : literal, ( n -- ) 187 | push , ; 188 | 189 | : rel>abs here cell + - ; 190 | 191 | : compile, ( xt -- ) 192 | rcall rel>abs , ; 193 | : branch-to ( addr -- ) 194 | branch rel>abs , ; 195 | : 0branch-to ( addr -- ) 196 | 0branch rel>abs , ; 197 | : ?branch-to ( addr -- ) 198 | ?branch rel>abs , ; 199 | 200 | : ['] ' literal, ; immediate compile-only 201 | 202 | : literal 203 | literal, ; immediate compile-only 204 | 205 | \ Partial implementation of POSTPONE, it works for non-immediate words. 206 | \ [COMPILE] words for immedaite words, but we cannot use IF, therefore 207 | \ we cannot define POSTPONE properly yet. 208 | : postpone-non-immediate, ( xt -- ) 209 | literal, ['] compile, compile, ; 210 | : postpone ' 211 | postpone-non-immediate, ; immediate 212 | 213 | 214 | \ Forward references 215 | 216 | : forward-literal ( -- addr ) 217 | push here 0 , ; 218 | : patch-forward-literal ( addr n -- ) 219 | swap ! ; 220 | 221 | : forward-branch 222 | branch here 0 , ; 223 | : forward-0branch 224 | 0branch here 0 , ; 225 | : forward-?branch 226 | ?branch here 0 , ; 227 | : patch-forward-branch ( jmp-addr target -- ) 228 | over cell + - swap ! ; 229 | 230 | 231 | \ CREATE...DOES> implementation 232 | \ 233 | \ Words which were defined with CREATE push their PFA to the 234 | \ stack. The PFA is the address where the word entry ends, so you can 235 | \ use CREATE to name locations in the dictionary, and hence, to 236 | \ implement variables and so. (See fig 1.) 237 | \ 238 | \ The runtime action of the word defined with CREATE can be changed, 239 | \ however. DOES> replaces the RET in the `create'd word with a JUMP 240 | \ to the dictionary point, allowing to append semantic to the word 241 | \ (See fig 2.) 242 | \ 243 | \ +-------------+ <--+ +-------------+ <-----+ 244 | \ | push PFA | | | push PFA | | 245 | \ | RET | | | jmp DOES> o-----+ | 246 | \ +-------------+ | +-------------+ | | 247 | \ | Previous | | | Previous | | | 248 | \ +-------------+ | +-------------+ | | 249 | \ NT ---> | u NAME flag | | NT ---> | u NAME flag | | | 250 | \ | CFA o--------+ | CFA o--------|--+ 251 | \ PFA --> +-------------+ PFA --> +-------------+ | 252 | \ | | | | | 253 | \ | | | | | 254 | \ +-------------+ DOES> +-------------+ <--+ 255 | \ | .... | 256 | \ | | 257 | \ +-------------+ 258 | \ 259 | \ fig 1. fig 2. 260 | \ 261 | 262 | : create-prologe ( -- forward-literal xt ) 263 | here forward-literal swap 264 | return 265 | nop 266 | nop 267 | nop 268 | nop ; 269 | 270 | : >ret 271 | latest cell - 5 - ; 272 | 273 | : create 274 | create-prologe 275 | header reveal cfa! 276 | here patch-forward-literal ; 277 | 278 | : does>runtime 279 | dp >ret dp! 280 | rsp @ 1+ branch-to 281 | dp! ; 282 | 283 | : does> 284 | ['] does>runtime compile, return 285 | ; immediate compile-only 286 | 287 | 288 | \ ALIAS 289 | : alias header reveal cfa! ; 290 | 291 | \ VARIABLE & CONSTANT 292 | : variable create 0 , ; 293 | : constant create , does> @ ; 294 | 295 | \ BEGIN-UNTIL 296 | \ BEGIN-WHILE-REPEAT 297 | \ BEGIN-AGAIN 298 | 299 | : begin ( -- begin-addr ) 300 | here 301 | ; immediate compile-only 302 | 303 | : until ( begin-addr -- ) 304 | 0branch-to 305 | ; immediate compile-only 306 | 307 | : while ( begin-addr -- begin-addr while-addr ) 308 | forward-0branch 309 | ; immediate compile-only 310 | 311 | : repeat ( begin-addr while-addr -- ) 312 | swap 313 | branch-to 314 | here patch-forward-branch 315 | ; immediate compile-only 316 | 317 | : again ( begin-addr -- ) 318 | branch-to 319 | ; immediate compile-only 320 | 321 | 322 | \ IF-THEN 323 | \ IF-ELSE-THEN 324 | 325 | : if ( -- if-forward-jmp ) 326 | forward-0branch 327 | ; immediate compile-only 328 | 329 | : else ( if-forward-jmp -- else-for) 330 | forward-branch swap 331 | here patch-forward-branch 332 | ; immediate compile-only 333 | 334 | : then 335 | here patch-forward-branch 336 | ; immediate compile-only 337 | 338 | ' then alias endif immediate compile-only 339 | 340 | : ?dup 341 | dup 0<> if dup then ; 342 | 343 | : postpone, 344 | swap if compile, else postpone-non-immediate, endif ; 345 | 346 | : postpone 347 | comp' postpone, ; immediate 348 | 349 | : ]L ] postpone literal ; 350 | 351 | 352 | \ [?]DO-[+]LOOP 353 | 354 | : do ( -- null-forward-branch do-addr ) 355 | postpone 2>r 356 | \ null forward-branch 357 | 0 358 | here 359 | ; immediate compile-only 360 | 361 | : ?do ( -- forward-branch do-addr ) 362 | postpone 2dup 363 | postpone 2>r 364 | postpone = 365 | forward-?branch 366 | here 367 | ; immediate compile-only 368 | 369 | \ Check if LIMIT and INDEX are such that we 370 | \ shouldn't go ahead with the ?DO..+LOOP iteration. 371 | : +endloop? ( n limit index -- flag ) 372 | swap 373 | - sf? >r 374 | swap - sf? nip r> 375 | <> ; 376 | 377 | : +loop ( COMPILEATION: forward-branch do-addr -- 378 | RUNTIME: n -- ) 379 | \ Update the index 380 | postpone dup 381 | postpone r> 382 | postpone + 383 | postpone >r 384 | \ Check conditions 385 | postpone 2r@ 386 | postpone +endloop? 387 | postpone not 388 | ?branch-to 389 | ?dup 0<> if 390 | here patch-forward-branch 391 | then 392 | postpone 2r> 393 | postpone 2drop 394 | ; immediate compile-only 395 | 396 | : loop ( forward-branch do-addr -- ) 397 | 1 398 | postpone literal 399 | postpone +loop 400 | ; immediate compile-only 401 | 402 | : unloop 403 | \ We are careful in order not to corrupt the caller's pointer. 404 | rsp @ 405 | rsp 2 cells + rsp! 406 | rsp ! 407 | ; compile-only 408 | 409 | : leave 410 | postpone 2r> 411 | postpone nip 412 | postpone dup 413 | postpone 1- 414 | postpone 2>r 415 | ; immediate compile-only 416 | 417 | 418 | : i rsp 1 cells + @ ; compile-only 419 | : j rsp 3 cells + @ ; compile-only 420 | : k rsp 5 cells + @ ; compile-only 421 | 422 | : abs 423 | dup 0< if negate then ; 424 | 425 | : max 426 | 2dup < if nip else drop then ; 427 | 428 | : min 429 | 2dup > if nip else drop then ; 430 | 431 | : pick ( xn ... x0 u -- xn ... x0 xu ) 432 | 1+ cells sp + @ ; 433 | 434 | : roll ( xn ... x1 x0 n -- xn-1 .. x0 xn ) 435 | dup 1+ pick >r 436 | 0 swap ?do \ Replace x_i por x_{i-1} 437 | sp i 1- cells + @ 438 | sp i 1+ cells + ! \ Note that tehre is an extra element due to the previous line. 439 | -1 +loop 440 | drop r> 441 | ; 442 | 443 | : ndrop ( xn .. x1 x0 n --- ) 444 | 1+ cells sp + sp! ; 445 | 446 | : 2over 3 pick 3 pick ; 447 | : 2tuck 2swap 2over ; 448 | : 2rot 5 roll 5 roll ; 449 | 450 | \ Like ALLOT but initialize memory to 0. 451 | : zallot ( n -- ) 452 | dup 0 < if 453 | allot 454 | else 455 | here swap 456 | dup allot 457 | 0 fill 458 | endif ; 459 | 460 | : move ( c-from c-to u ) 461 | >r 2dup < if r> cmove> else r> cmove then ; 462 | 463 | create pad 1024 allot 464 | 465 | : low-byte 255 and ; 466 | : high-byte 8 rshift low-byte ; 467 | 468 | : printable-char? ( ch -- flag ) 469 | dup $20 >= 470 | swap $7e <= and ; 471 | 472 | \ Facility for defining harmful state-smartess words. 473 | \ I did not know, when I wrote this, what state-smartness were bad. 474 | \ So, if you want to learn well Forth, you should not read this code, 475 | \ probably. 476 | : if-compiling 477 | postpone state 478 | postpone @ 479 | postpone if 480 | ; immediate 481 | 482 | \ CASE's implementation imported from Gforth. 483 | \ 484 | \ Usage 485 | \ ( n ) 486 | \ CASE 487 | \ 1 OF .... ENDOF 488 | \ 2 OF .... ENDOF 489 | \ OTHERWISE 490 | \ END-CASE 491 | \ 492 | \ Remember not to consume the element in the OTHERWISE case. 493 | 494 | 0 constant case immediate 495 | 496 | : of 497 | 1+ >r 498 | postpone over 499 | postpone = 500 | postpone if 501 | postpone drop 502 | r> 503 | ; immediate 504 | 505 | : endof 506 | >r postpone else r> 507 | ; immediate 508 | 509 | : endcase 510 | postpone drop 511 | 0 ?do postpone then loop 512 | ; immediate 513 | 514 | 515 | : char 516 | begin 517 | parse-char case 518 | 09 of endof 519 | 10 of endof 520 | 13 of endof 521 | 32 of endof 522 | exit 523 | endcase 524 | again ; 525 | 526 | : [char] 527 | char postpone literal ; immediate 528 | 529 | 32 constant bl 530 | 531 | \ Push the amount of free memory in the dictionary. 532 | : unused 533 | dp-base dp - ; 534 | 535 | \ Interprete a string 536 | 537 | : buffer>start ( addr -- start ) 538 | @ ; 539 | 540 | : buffer>size ( addr -- size ) 541 | cell + @ ; 542 | 543 | : buffer>loaded ( addr -- load-var ) 544 | 2 cells + ; 545 | 546 | : buffer>nt ( addr -- nt ) 547 | 3 cells + @ ; 548 | 549 | : buffer>string ( addr -- addr u ) 550 | dup buffer>start swap buffer>size ; 551 | 552 | : buffer-loaded? ( addr -- flag ) 553 | buffer>loaded @ ; 554 | 555 | : mark-buffer-as-loaded ( addr -- ) 556 | buffer>loaded true swap ! ; 557 | @core.fs mark-buffer-as-loaded 558 | 559 | variable load-buffer-print-hook 560 | variable load-buffer-print 561 | ' drop load-buffer-print-hook ! 562 | load-buffer-print on 563 | 564 | : load-buffer ( addr -- ) 565 | dup mark-buffer-as-loaded 566 | load-buffer-print @ if 567 | dup load-buffer-print-hook @ execute 568 | endif 569 | buffer>string evaluate ; 570 | 571 | : require-buffer ( addr -- ) 572 | dup buffer-loaded? if drop else load-buffer then ; 573 | 574 | 575 | \ Recursion 576 | 577 | : recurse latestxt compile, ; immediate compile-only 578 | ' reveal alias recursive immediate 579 | 580 | \ Enumerations. See kernel/irq.fs for usage. 581 | : enum dup constant 1+ ; 582 | : end-enum drop ; 583 | 584 | @structures.fs require-buffer 585 | @exceptions.fs require-buffer 586 | 587 | \ Complete the following definitions to support error handling. 588 | : nt' 589 | parse-nt dup 0= if -13 throw then ; 590 | : comp' 591 | nt' nt>comp ; 592 | : ' 593 | comp' nip ; 594 | : [nt'] 595 | nt' postpone literal ; immediate compile-only 596 | : [comp'] 597 | comp' postpone literal ; immediate compile-only 598 | : ['] 599 | ' postpone literal ; immediate compile-only 600 | : postpone 601 | comp' postpone, ; immediate 602 | : [compile] 603 | ' compile, ; immediate 604 | 605 | \ Parse a word from input buffer and store N in its PFA. 606 | : 'pfa! ( n -- ) 607 | nt' nt>pfa 608 | if-compiling 609 | postpone literal 610 | postpone ! 611 | else 612 | ! 613 | endif 614 | ; immediate 615 | 616 | 617 | \ Values 618 | 619 | : VALUE ( n -- ) 620 | create , does> @ ; 621 | 622 | : TO ( n -- ) 623 | postpone 'pfa! ; immediate 624 | 625 | 626 | \ Defered words 627 | : DEFER 628 | create ['] abort , does> @ execute ; 629 | : IS 630 | postpone 'pfa! ; immediate 631 | 632 | 633 | \ A syntax sugar for require-buffer 634 | : require 635 | ' 636 | if-compiling 637 | postpone literal 638 | postpone execute 639 | postpone require-buffer 640 | else 641 | execute 642 | require-buffer 643 | endif 644 | ; immediate 645 | 646 | : include 647 | ' 648 | if-compiling 649 | postpone literal 650 | postpone execute 651 | postpone load-buffer 652 | else 653 | execute 654 | require-buffer 655 | endif 656 | ; immediate 657 | 658 | 659 | require @interpreter.fs 660 | require @math.fs 661 | require @string.fs 662 | 663 | : count ( c-addr -- addr u ) 664 | dup c@ swap 1+ swap ; 665 | 666 | : c>addr ( addr u addr -- ) 667 | 2dup 2>r 1+ swap move 2r> c! ; 668 | 669 | : c-addr ( addr u -- c-addr ) 670 | pad c>addr pad ; 671 | 672 | : parse-name ( -- addr u ) 673 | parse-cname count ; 674 | 675 | \ NAMED AND NONAMED WORDS 676 | 677 | create nextname-buffer 32 allot 678 | 679 | : nextname ( addr u -- ) 680 | nextname-buffer c>addr 681 | nextname-buffer compiling_nextname ! ; 682 | 683 | : noname 0 0 nextname ; 684 | : :noname noname : latestxt ; 685 | 686 | \ If flag is true, parse a name of word and create a alias for NOOP, 687 | \ otherwise the parsed word is discarded. It is used to define 688 | \ features in the environment as #define in C. You can use 689 | \ [ifdef]..[endif] to check the availability of features. 690 | : feature ( flag -- ) 691 | parse-name rot if 692 | nextname ['] noop alias 693 | else 694 | 2drop 695 | endif ; 696 | 697 | require @vocabulary.fs 698 | require @kernel/multiboot.fs 699 | require @memory.fs 700 | require @kernel/console.fs 701 | require @colors.fs 702 | require @output.fs 703 | 704 | \ From here, we have both exceptions and a console, so we can catch 705 | \ and report errors in a more convenient. Exceptions will be fatal. 706 | 707 | : fatal-catch ( xt -- ) 708 | catch ?dup if 709 | ." FATAL: " 710 | case 711 | -1 of ." Aborted" cr endof 712 | -3 of ." Stack overflow" cr endof 713 | -4 of ." Stack underflow" cr endof 714 | -10 of ." Division by zero" cr endof 715 | -13 of ." Unknown word" cr endof 716 | -14 of ." Compile-only word" cr endof 717 | ." Ocurred an unexpected error of code " dup . cr 718 | endcase 719 | ." >>>" read_word_buffer count type ." <<<" cr 720 | endif 721 | cli halt ; 722 | 723 | :noname -3 throw ; stack_overflow_err_routine ! 724 | :noname -4 throw ; stack_underflow_err_routine ! 725 | :noname -13 throw ; unknown_word_err_routine ! 726 | :noname -14 throw ; compile_only_err_routine ! 727 | 728 | @corestage2.fs ' require-buffer fatal-catch 729 | 730 | \ core.fs ends here 731 | -------------------------------------------------------------------------------- /corestage2.fs: -------------------------------------------------------------------------------- 1 | \ corestage2.fs --- 2 | 3 | \ Copyright 2011, 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | LIGHT GRAY UPON BLACK 21 | -1 -1 at-xy update-hardware-cursor 22 | .( Loading...) CR 23 | :noname 24 | ." Loading " buffer>nt id. ." ..." cr 25 | ; load-buffer-print-hook ! 26 | 27 | require @tools.fs 28 | require @kernel/interrupts.fs 29 | require @kernel/exceptions.fs 30 | require @debugger.fs 31 | require @kernel/irq.fs 32 | require @kernel/timer.fs 33 | require @kernel/floppy.fs 34 | require @kernel/keyboard.fs 35 | require @kernel/serial.fs 36 | require @kernel/speaker.fs 37 | require @tests/tests.fs 38 | require @kernel/cpuid.fs 39 | require @blocks.fs 40 | require @input.fs 41 | 42 | \ Rebooting the machine 43 | 44 | : reboot 45 | beep 46 | disable-interrupts 47 | clear-kbd-buffer 48 | kdb-reset kbd-io outputb 49 | halt ; 50 | 51 | \ Timing 52 | 53 | variable execute-timing-start 54 | : execute-timing ( xt -- ms ) 55 | \ TODO: Replace . by u. when it exists. 56 | get-internal-run-time execute-timing-start ! 57 | execute 58 | get-internal-run-time execute-timing-start @ - 59 | CR ." Execution took " . ." miliseconds of run time." ; 60 | 61 | \ Date & Time 62 | \ TODO: Move this to a better place 63 | 64 | : cmos $70 outputb $71 ( 1 ms ) inputb ; 65 | : cmos! $70 outputb $71 ( 1 ms ) outputb ; 66 | 67 | variable bcd? 68 | : ?bcd>bin bcd? @ if dup 4 rshift 10 * swap $f and + endif ; 69 | 70 | : cmos-time-updating? 71 | $0b cmos $80 and ; 72 | : wait-cmos-time-updating 73 | begin cmos-time-updating? not until ; 74 | 75 | : decode-cmos-time ( -- second minute hour date month year ) 76 | wait-cmos-time-updating 77 | $0b cmos $04 and if bcd? off else bcd? on endif 78 | $00 cmos ?bcd>bin \ seconds 79 | $02 cmos ?bcd>bin \ minute 80 | $04 cmos ?bcd>bin \ hour 81 | $07 cmos ?bcd>bin \ date 82 | $08 cmos ?bcd>bin \ month 83 | $09 cmos ?bcd>bin \ year 84 | ; 85 | : .date 86 | decode-cmos-time -rot swap 87 | print-number [char] / emit 88 | print-number [char] / emit 89 | print-number 90 | space 91 | print-number [char] : emit 92 | print-number [char] : emit 93 | print-number ; 94 | 95 | 96 | \ Markers 97 | 98 | : marker-restore-wordlist ( wid -- ) 99 | begin here over wid>latest u<= while 100 | dup wid>latest previous-word over wid-latest ! 101 | repeat 102 | drop ; 103 | 104 | : marker-restore-wordlists 105 | last-wid @ 106 | begin ?dup while 107 | dup marker-restore-wordlist 108 | wid-previous @ 109 | repeat ; 110 | 111 | : marker here create , does> @ dp! marker-restore-wordlists ; 112 | 113 | 114 | ( run-tests ) 115 | 116 | \ DEBUGGING. This is useful to run the QEMU on emacs, and use Eulex 117 | \ like anyother Forth implementation! 118 | 119 | \ : serial-loop 120 | \ ." Initializing serial port interface..." cr 121 | \ ['] read-byte input_routine ! ; 122 | 123 | \ serial-echo-on 124 | \ serial-loop 125 | 126 | enable-interrupts 127 | initialize-floppy 128 | QWERTY setxkmap 129 | 130 | require @user.fs 131 | 132 | \ corestage2.fs ends here 133 | -------------------------------------------------------------------------------- /debugger.fs: -------------------------------------------------------------------------------- 1 | \ debugger.fs -- 2 | 3 | \ Copyright 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @structures.fs 21 | require @kernel/interrupts.fs 22 | 23 | variable last-breakpoint 24 | 25 | struct 26 | cell field breakpoint-nt 27 | cell field breakpoint-addr 28 | cell field breakpoint-byte 29 | cell field breakpoint-previous 30 | cell field breakpoint-next 31 | cell field breakpoint-oneshot? 32 | end-struct breakpoint% 33 | 34 | : breakpoint-enable? ( breakpoint -- ) 35 | breakpoint-addr @ c@ $cc = ; 36 | 37 | : enable-breakpoint ( breakpoint -- ) 38 | dup breakpoint-enable? if drop else 39 | dup breakpoint-addr @ c@ over breakpoint-byte ! 40 | $cc swap breakpoint-addr @ c! 41 | endif ; 42 | 43 | : disable-breakpoint ( breakpoint -- ) 44 | dup breakpoint-enable? not if drop else 45 | dup breakpoint-byte @ swap breakpoint-addr @ c! 46 | endif ; 47 | 48 | : find-breakpoint ( addr -- breakpoint% ) 49 | last-breakpoint @ 50 | begin dup while 51 | 2dup breakpoint-addr @ = if nip exit endif 52 | breakpoint-next @ 53 | repeat 54 | nip ; 55 | 56 | : install-breakpoint ( nt addr -- breakpoint%|0 ) 57 | dup find-breakpoint if 2drop 0 else 58 | breakpoint% allocate throw 59 | tuck breakpoint-addr ! 60 | tuck breakpoint-nt ! 61 | last-breakpoint @ over breakpoint-next ! 62 | 0 over breakpoint-previous ! 63 | dup last-breakpoint ! 64 | dup enable-breakpoint 65 | endif ; 66 | 67 | : delete-breakpoint ( breakpoint% -- ) 68 | dup breakpoint-next @ ?dup if 69 | over breakpoint-previous @ ?dup if breakpoint-next ! endif 70 | endif 71 | dup breakpoint-previous @ ?dup if 72 | over breakpoint-next @ ?dup if breakpoint-previous ! endif 73 | endif 74 | dup disable-breakpoint 75 | free throw ; 76 | 77 | : breakpoints 78 | last-breakpoint @ 79 | begin dup while 80 | dup breakpoint-nt @ id. breakpoint-previous @ 81 | repeat 82 | drop ; 83 | 84 | 85 | variable reseting-breakpoing 86 | 87 | : debug-exception ( isrinfo -- ) 88 | [ $100 invert ]L over isrinfo-eflags and! 89 | reseting-breakpoing @ ?dup if 90 | dup breakpoint-oneshot? @ if 91 | reseting-breakpoing 0! 92 | else 93 | enable-breakpoint 94 | endif 95 | endif 96 | ; 1 ISR 97 | 98 | : traced-function-hook ( nt -- ) 99 | CR ." TRACE: The word " id. ." was called." ; 100 | 101 | : breakpoint-exception ( isrinfo -- ) 102 | \ Set trap flag (single-step mode). It will generate ISR#1 103 | \ interruption to be called, so we can replace the original byte 104 | \ with the breakpoint instruction again. 105 | $100 over isrinfo-eflags or! 106 | \ Replace the break instruction with the original byte. 107 | dup isrinfo-eip @ 1- find-breakpoint 108 | dup disable-breakpoint 109 | dup reseting-breakpoing ! 110 | dup breakpoint-nt @ traced-function-hook 111 | breakpoint-addr @ swap isrinfo-eip ! 112 | ; 3 ISR 113 | 114 | 115 | : parse-and-trace 116 | nt' dup nt>xt install-breakpoint 117 | dup 0= if ." This word is being traced." CR endif ; 118 | 119 | : trace parse-and-trace drop ; 120 | : trace1 parse-and-trace breakpoint-oneshot? on ; 121 | 122 | : untrace ' 123 | find-breakpoint ?dup if 124 | delete-breakpoint 125 | else ." This word is not traced." CR endif ; 126 | 127 | \ debugger.fs ends here 128 | -------------------------------------------------------------------------------- /disassem.fs: -------------------------------------------------------------------------------- 1 | \ disassem.fs -- Pseudo-disassembler (debugging) 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ This file implements an ad-hoc disassembler for non-primitive Forth 21 | \ words. It is a big CASE for every opcodes which we emitted in some 22 | \ other point basically, but it was useful for debugging control-flow 23 | \ words specially. Eventually, however, if the Forth implementation 24 | \ was good and mature and it would be able to run a good disassembler, 25 | \ turning this code obsolete. 26 | 27 | create distable 256 cells allot 28 | 29 | : unknown-opcode 30 | attr >r light red 31 | ." [unkown opcode " 32 | dup c@ print-number 33 | ." '" 34 | dup c@ emit 35 | ." ']" 36 | 1+ 37 | r> attr! ; 38 | 39 | \ Initialize the entries with the unknown-opcode controller 40 | : init-distable 41 | 256 0 ?do 42 | ['] unknown-opcode 43 | distable i cells + ! 44 | loop 45 | ; 46 | 47 | : defdisam [compile] :noname ; 48 | : ;dis [compile] ; swap cells distable + ! ; immediate 49 | 50 | : disassemble-name ( addr -- ) 51 | dup print-hex-number 52 | unfind 53 | dup 0= if 54 | 2drop 55 | else 56 | ." <" type ." >" 57 | then 58 | ; 59 | 60 | : disassemble-rel-name ( addr -- ) 61 | dup @ 4 + + disassemble-name ; 62 | 63 | : disassemble-instruction ( addr -- next-addr ) 64 | dup addr-column 65 | dup c@ cells distable + @ execute cr ; 66 | 67 | : ret? $c3 = ; 68 | : disassemble-memory 69 | cr 70 | begin dup disassemble-instruction swap c@ ret? until 71 | drop ; 72 | 73 | : disassemble ' disassemble-memory ; 74 | 75 | ' disassemble alias see 76 | 77 | INIT-DISTABLE 78 | 79 | $0f defdisam ( 0f 85 ) 80 | 1+ dup c@ case 81 | $85 of ." JNZ " 1+ dup disassemble-rel-name cell + endof 82 | $84 of ." JZ " 1+ dup disassemble-rel-name cell + endof 83 | nip 84 | endcase 85 | ;dis 86 | 87 | $29 defdisam ( 29 f8 ) 88 | ." SUBL %EDI, %EAX" 2+ ;dis 89 | 90 | $47 defdisam ." INCL (%EDI)" 1+ ;dis 91 | 92 | $83 defdisam 93 | 1+ dup c@ 94 | case 95 | $0c4 of 96 | ." ADDL $" 97 | dup 1+ c@ print-hex-number 98 | ." , %ESP" 99 | 2 + 100 | endof 101 | $0c7 of ." ADDL $4, %EDI" 2 + endof 102 | $0c6 of ." ADDL $4, %ESI" 2 + endof 103 | $0ee of ." SUBL $4, %ESI" 2 + endof 104 | $0e8 of ." SUBL $4, %EAX" 2 + endof 105 | swap unknown-opcode swap 106 | endcase 107 | ;dis 108 | 109 | $60 defdisam ." PUSHA" 1+ ;dis 110 | $61 defdisam ." POPA" 1+ ;dis 111 | 112 | $68 defdisam ." PUSH $" dup 1+ @ print-hex-number 5 + ;dis 113 | 114 | $85 defdisam ( 85 c0 ) 115 | ." TEST %EAX, %EAX" 116 | 2+ 117 | ;dis 118 | 119 | $89 defdisam ( 89 07 ) 120 | ." MOVL %EAX, (%EDI)" 2+ 121 | ;dis 122 | 123 | $8b defdisam ( 8b 06 ) 124 | ." MOVL (%ESI), %EAX" 2+ 125 | ;dis 126 | 127 | $90 defdisam ." NOP" 1+ ;dis 128 | 129 | $a1 defdisam ." MOVL " 1+ dup @ print-hex-number cell + ." , %EAX" ;dis 130 | 131 | $b8 defdisam ." MOVL $" 1+ dup @ print-hex-number cell + ." , %EAX" ;dis 132 | 133 | $e8 defdisam ." CALL " 1+ dup disassemble-rel-name cell + ;dis 134 | 135 | $e9 defdisam ." JMP " 1+ dup disassemble-rel-name cell + ;dis 136 | 137 | $eb defdisam ." JMP " 1+ dup dup c@ + 1+ print-hex-number 1+ ;dis 138 | 139 | $c3 defdisam ." RET" 1+ ;dis 140 | 141 | $c7 defdisam 142 | 1+ dup c@ 143 | case 144 | $46 of ." MOVL $" 2+ dup @ print-number ." , -4(%ESI)" cell + endof 145 | $06 of ." MOVL $" 1+ dup @ print-number ." , (%ESI)" cell + endof 146 | $07 of ." MOVL $" 1+ dup @ print-number ." , (%EDI)" cell + endof 147 | swap unknown-opcode swap 148 | endcase 149 | ;dis 150 | 151 | $cf defdisam ." IRET" 1+ ;dis 152 | 153 | $fa defdisam ." CLI " 1+ ;dis 154 | 155 | $fb defdisam ." STI " 1+ ;dis 156 | 157 | $ff defdisam ( ff d0 ) 2+ ." CALL *%EAX" ;dis 158 | 159 | 160 | \ Local Variables: 161 | \ forth-local-words: ((("defdisam") definition-starter (font-lock-keyword-face . 2)) 162 | \ ((";dis") definition-ender (font-lock-keyword-face . 2))) 163 | \ End: 164 | 165 | \ disassem.fs ends here 166 | -------------------------------------------------------------------------------- /editor.fs: -------------------------------------------------------------------------------- 1 | \ editor.fs --- Real-time display block editor 2 | 3 | \ Copyright 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ TODO: Mark commands with a special flag to allow ordinary Forth 21 | \ words in the EDITOR-CMDS vocabulary. 22 | 23 | VOCABULARY EDITOR 24 | VOCABULARY EDITOR-CMDS 25 | 26 | EULEX 27 | ALSO EDITOR 28 | ALSO EDITOR DEFINITIONS 29 | 30 | require @kernel/console.fs 31 | require @colors.fs 32 | require @blocks.fs 33 | 34 | variable nblock 35 | variable buffer 36 | variable &point 37 | 38 | : memshift> ( addr u c -- ) swap >r 2dup + swap r> - abs cmove> ; 39 | : r over + swap r> cmove ; 40 | 41 | : point &point @ ; 42 | : goto-char &point ! ; 43 | 44 | true value visible-bell 45 | : flash invert-screen 50 ms invert-screen ; 46 | : alert visible-bell if flash else beep endif ; 47 | 48 | : line-number-at-pos 64 / ; 49 | : column-number-at-pos 64 mod ; 50 | : line point line-number-at-pos ; 51 | : column point column-number-at-pos ; 52 | : right-column 63 column - ; 53 | : line-beginning-position point column - ; 54 | : line-end-position line-beginning-position 63 + ; 55 | : position>addr chars buffer @ + ; 56 | : char-at position>addr c@ ; 57 | : point>addr point position>addr ; 58 | 59 | : position>screen 64 /mod 4 + swap 7 + swap ; 60 | : update-cursor point position>screen at-xy update-hardware-cursor ; 61 | 62 | : box-corners 63 | 06 03 at-xy $da emit-char 64 | 71 03 at-xy $bf emit-char 65 | 06 20 at-xy $c0 emit-char 66 | 71 20 at-xy $d9 emit-char ; 67 | 68 | : --- 0 ?do $c4 emit-char loop ; 69 | : | $b3 emit-char ; 70 | : .2 dup 10 < if $20 emit-char then . ; 71 | 72 | : box 73 | gray upon black 74 | 07 03 at-xy 64 --- 75 | 16 00 ?do cr 3 spaces i .2 | 64 spaces | loop 76 | 07 20 at-xy 64 --- 77 | box-corners ; 78 | 79 | : render-title 80 | upon blue 80 spaces 81 | 36 0 at-xy light cyan ." EDITOR " ; 82 | 83 | create minibuffer-string 79 chars allot 84 | : render-modeline 85 | attr 86 | 00 23 at-xy upon blue 80 spaces 87 | 03 23 at-xy light cyan ." Block: " nblock ? 88 | attr! ; 89 | 90 | : render-minibuffer 91 | 00 24 at-xy light gray upon black minibuffer-string 79 type ; 92 | 93 | : render-application 94 | page render-title box render-modeline render-minibuffer ; 95 | 96 | \ Bitmap of lines which need to be redrawn 97 | variable lines-to-render 98 | : safe-emit dup 32 < if drop [char] . then emit ; 99 | : safe-type 0 ?do dup c@ safe-emit 1+ loop drop ; 100 | : render-line 101 | 64 * dup position>screen at-xy position>addr 64 safe-type ; 102 | : render 103 | lines-to-render @ 104 | 16 0 ?do dup 1 and if i render-line endif 1 rshift loop 105 | lines-to-render ! 106 | render-minibuffer ; 107 | : redraw-line 1 line lshift lines-to-render or! ; 108 | : redraw-buffer -1 lines-to-render ! ; 109 | : redraw-lines ( from to -- ) 110 | 1 swap 1+ lshift 1- swap 111 | 1 swap lshift 1- negate .s 112 | lines-to-render or! ; 113 | 114 | create command-name 80 chars allot 115 | : in-editor-cmds: also editor-cmds context @ 1 set-order ; 116 | : read-command 117 | get-order in-editor-cmds: 118 | 0 24 at-xy ." M-x " command-name dup 74 accept 119 | c-addr find-cname >r 120 | set-order r> ; 121 | 122 | \ Commands 123 | 124 | variable editor-loop-quit 125 | variable last-read-key 126 | create keymap 1024 cells zallot 127 | 128 | : out-of-range? 0 swap 1023 between not ; 129 | 130 | : at-beginning? point 0 = ; 131 | : at-end? point 1023 = ; 132 | 133 | : move-char ( n -- ) 134 | point + dup out-of-range? if abort else goto-char then ; 135 | 136 | : white-string? -trailing nip 0= ; 137 | : empty-line? ( u -- bool ) 138 | 960 position>addr 64 white-string? ; 139 | 140 | : shift> ( addr u c -- ) 141 | rot dup >r -rot dup >r memshift> r> r> swap 32 fill ; 142 | : r dup >r r> swap 32 fill ; 144 | 145 | : [INTERNAL] also editor definitions ; 146 | : [END] previous definitions ; 147 | 148 | ' point alias 150 | 151 | : message ( addr u -- ) 152 | minibuffer-string 79 32 fill 153 | 79 min minibuffer-string swap move ; 154 | 155 | : clear-minibuffer 156 | 0 0 message ; 157 | 158 | : substring ( position1 position2 -- ) 159 | over - >r position>addr r> ; 160 | 161 | : open-buffer ( u -- ) 162 | dup nblock ! 163 | block buffer ! 164 | redraw-buffer render-modeline ; 165 | 166 | EDITOR-CMDS DEFINITIONS 167 | 168 | : beginning-of-line line-beginning-position goto-char ; 169 | ' beginning-of-line alias bol 170 | : end-of-line line-end-position goto-char ; 171 | ' end-of-line alias eol 172 | 173 | [INTERNAL] 174 | : whole-line ; 175 | : rest-of-line ; 176 | [END] 177 | 178 | : rewind 179 | rest-of-line white-string? if 180 | begin point char-at 32 = column 0<> and while -1 move-char repeat 181 | point char-at 32 <> if 1 move-char then 182 | then ; 183 | 184 | : next-line 64 move-char rewind ; 185 | : previous-line -64 move-char rewind ; 186 | 187 | : forward-char 188 | rest-of-line tuck white-string? not if drop 1 then 189 | move-char ; 190 | 191 | : backward-char 192 | column 0= if previous-line eol rewind else -1 move-char endif ; 193 | 194 | : beginning-of-buffer 0 goto-char ; : end-of-buffer 1023 goto-char ; 195 | ' beginning-of-buffer alias bob ' end-of-buffer alias eob 196 | 197 | : beginning-of-paragraph 198 | bol begin at-beginning? if exit then 199 | point 1- char-at 32 <> while 200 | previous-line 201 | repeat ; 202 | ' beginning-of-paragraph alias bop 203 | 204 | : end-of-paragraph 205 | eol begin point char-at 32 <> at-end? not and while 206 | next-line 207 | repeat 208 | rewind ; 209 | ' end-of-paragraph alias eop 210 | 211 | : forward-word 212 | begin point char-at 32 = at-end? not and while 1 move-char repeat 213 | begin point char-at 32 <> at-end? not and while 1 move-char repeat ; 214 | 215 | : backward-word 216 | at-beginning? not if -1 move-char then 217 | begin point char-at 32 = at-beginning? not and while -1 move-char repeat 218 | begin point char-at 32 <> at-beginning? not and while -1 move-char repeat 219 | at-beginning? not if 1 move-char then ; 220 | 221 | [INTERNAL] 222 | : whole-paragraph ; 223 | : whole-buffer ; 224 | 225 | : rest-of-paragraph ; 226 | : rest-of-buffer ; 227 | [END] 228 | 229 | : erase-buffer whole-buffer 32 fill bob ; 230 | 231 | : newline 232 | 15 empty-line? not if abort then 233 | E> 234 | point>addr right-column 65 + right-column 1+ shift> 235 | eol 1 move-char redraw-buffer ; 236 | 237 | : self-insert-command 238 | rest-of-paragraph 1 memshift> 239 | last-read-key @ point>addr c! 240 | 1 move-char redraw-buffer ; 241 | 242 | : delete-char rest-of-paragraph 1 xt execute else abort then ; 247 | 248 | : load-buffer 249 | save-screen sp >r 250 | light gray upon black 251 | page update-hardware-cursor 252 | nblock @ load 253 | r> sp! restore-screen 254 | redraw-buffer ; 255 | 256 | : save-buffer 257 | update flush s" Block changes saved." message ; 258 | 259 | : next-buffer nblock @ 1 + open-buffer ; 260 | : previous-buffer nblock @ ?dup if 1- open-buffer then ; 261 | 262 | : kill-editor editor-loop-quit on ; 263 | 264 | 265 | ALSO EDITOR DEFINITIONS 266 | 267 | : ekey->kbd 268 | dup alt-mod and if swap $100 + swap then 269 | ctrl-mod and if $200 + then ; 270 | 271 | : read-key ekey ekey->kbd dup last-read-key ! ; 272 | : kbd-command cells keymap + @ ; 273 | 274 | : M- char $100 + ; 275 | : C- char $200 + ; 276 | : C-M- char $300 + ; 277 | : key-for: nt' swap cells keymap + ! ; 278 | 279 | : C-X-dispatcher 280 | read-key case 281 | [ C- s ]L of save-buffer endof 282 | [ C- c ]L of kill-editor endof 283 | abort 284 | endcase ; 285 | 286 | UP key-for: previous-line 287 | DOWN key-for: next-line 288 | LEFT key-for: backward-char 289 | RIGHT key-for: forward-char 290 | BACK key-for: delete-backward-char 291 | RET key-for: newline 292 | 293 | M- x key-for: execute-extended-command 294 | M- < key-for: beginning-of-buffer 295 | M- > key-for: end-of-buffer 296 | M- f key-for: forward-word 297 | M- b key-for: backward-word 298 | 299 | $100 RIGHT + key-for: next-buffer 300 | $100 LEFT + key-for: previous-buffer 301 | 302 | C- x key-for: C-X-dispatcher 303 | C- f key-for: forward-char 304 | C- b key-for: backward-char 305 | C- p key-for: previous-line 306 | C- n key-for: next-line 307 | C- d key-for: delete-char 308 | C- a key-for: beginning-of-paragraph 309 | C- e key-for: end-of-paragraph 310 | C- c key-for: load-buffer 311 | 312 | 313 | :noname 314 | 127 32 ?do [nt'] self-insert-command i cells keymap + ! loop 315 | ; execute 316 | 317 | PREVIOUS EDITOR-CMDS 318 | PREVIOUS EDITOR 319 | DEFINITIONS 320 | 321 | \ Command dispatch 322 | 323 | : editor-loop 324 | editor-loop-quit off 325 | begin 326 | render update-cursor redraw-line 327 | read-key clear-minibuffer kbd-command ?dup if 328 | nt>xt ['] execute catch if drop alert then 329 | else alert then 330 | redraw-line 331 | editor-loop-quit @ until ; 332 | 333 | : edit ( u -- ) 334 | dup nblock ! block buffer ! 335 | save-screen 336 | clear-minibuffer 337 | 0 goto-char 338 | render-application redraw-buffer 339 | editor-loop 340 | restore-screen ; 341 | 342 | ' EDIT 343 | PREVIOUS DEFINITIONS ALIAS EDIT 344 | 345 | \ editor.fs ends here 346 | -------------------------------------------------------------------------------- /eulex.lds: -------------------------------------------------------------------------------- 1 | OUTPUT_ARCH(i386) 2 | OUTPUT_FORMAT("elf32-i386") 3 | ENTRY(_start) 4 | SECTIONS 5 | { 6 | /DISCARD/ : { *(.note.gnu.build-id) } 7 | /DISCARD/ : { *(.note.gnu.gold-version) } 8 | 9 | .text 0x100000 : 10 | { 11 | code = .; _code = .; __code = .; 12 | *(.text) 13 | . = ALIGN(4096); 14 | } 15 | 16 | .data : 17 | { 18 | data = .; _data = .; __data = .; 19 | *(.data) 20 | *(.rodata) 21 | . = ALIGN(4096); 22 | } 23 | 24 | .bss : 25 | { 26 | bss = .; _bss = .; __bss = .; 27 | *(.bss) 28 | . = ALIGN(4096); 29 | } 30 | 31 | end = .; _end = .; __end = .; 32 | } 33 | -------------------------------------------------------------------------------- /exceptions.fs: -------------------------------------------------------------------------------- 1 | \ exceptions.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ NOTE ON THE IMPLEMENTATION: 21 | \ Exception handling relies on the couple of words CATCH...THROW. 22 | \ CATCH installs an exception handler and THROW signals an exception, 23 | \ jumping to the innermost exception handler. The stack is unwinded 24 | \ in CATCH time. Hence, we can access to the context of signal and 25 | \ display useful debugging information (e.g: backtraces). 26 | 27 | variable exception-handler 28 | 29 | : exception-handler-target 30 | exception-handler @ 2 cells + @ ; 31 | : exception-handler-previous 32 | exception-handler @ 1 cells + @ ; 33 | : exception-handler-sp 34 | exception-handler @ 0 cells + @ ; 35 | : drop-exception-handler 36 | exception-handler-previous exception-handler ! ; 37 | 38 | : %throw ( n -- ) 39 | dup if >r exception-handler-sp sp! r> then 40 | exception-handler-target jump ; 41 | 42 | : %catch-without-unwind ( xt -- ) 43 | \ Install exception handler 44 | exception-handler @ >r 45 | sp cell + >r 46 | rsp exception-handler ! 47 | \ Execute XT 48 | execute 49 | 0 %throw ; 50 | 51 | : %unwind-after-catch 52 | r> 53 | exception-handler @ rsp! 54 | drop-exception-handler 55 | r> drop 56 | r> drop 57 | r> drop 58 | >r ; 59 | 60 | : throw ( n -- ) 61 | ?dup 0<> if %throw then ; 62 | 63 | : catch ( ... XT -- ... n ) 64 | %catch-without-unwind 65 | %unwind-after-catch ; 66 | 67 | : abort -1 throw ; 68 | 69 | \ exceptions.fs ends here 70 | -------------------------------------------------------------------------------- /generate-builtin-files.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | # generate-builtin-files.sh -- Genera el archivo BUILTIN-FILES.S 3 | 4 | # After running this script with a list of files as argument, a file 5 | # named BUILTIN-FILES.S will be created whose content is a primitive 6 | # Forth word @FILENAME for each Forth file. This word leaves (in order) 7 | # in the # data stack the following information: 8 | # - The address of memory where the file begins. 9 | # - The size of the memory buffer. 10 | # - The address of memory of a free location to keep information. 11 | # (This variable is used to store if this file was loaded 12 | # in the Forth image currently) 13 | 14 | OUTPUT=BUILTIN-FILES.S 15 | 16 | echo "/* This file was generated automatically. Don't modify it. */" > $OUTPUT 17 | for file in $*; do 18 | BN=`echo $file | sed 's/\//_/g' | sed 's/\./_/g'` 19 | SYMBOL_START="_binary_${BN}_start" 20 | SYMBOL_SIZE="_binary_${BN}_size" 21 | echo "" >> $OUTPUT 22 | echo "BUILTIN_WORD_NAME(__$BN, \"@$file\")" >> $OUTPUT 23 | echo " movl \$__${BN}_data, -4(%esi)" >> $OUTPUT 24 | echo " subl \$4, %esi" >> $OUTPUT 25 | echo " ret" >> $OUTPUT 26 | echo "__${BN}_data:" >> $OUTPUT 27 | echo " .long $SYMBOL_START" >> $OUTPUT 28 | echo " .long $SYMBOL_SIZE" >> $OUTPUT 29 | echo " .long 0" >> $OUTPUT 30 | echo " .long begin___$BN" >> $OUTPUT 31 | echo "END_WORD(__$BN)" >> $OUTPUT 32 | done 33 | -------------------------------------------------------------------------------- /input.fs: -------------------------------------------------------------------------------- 1 | \ input.fs -- Input sources and stream 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @linedit.fs 21 | 22 | \ Will we write " ok" or " compiled" after refilling? 23 | variable refill-silent? 24 | 25 | ' input_buffer_in alias >IN 26 | 27 | : source-id ( -- n ) 28 | input_source_id @ ; 29 | 30 | : source ( -- addr n ) 31 | input_buffer @ 32 | input_buffer_size @ ; 33 | 34 | : save-input 35 | input_buffer @ 36 | input_buffer_in @ 37 | input_buffer_size @ 38 | input_source_line @ 39 | input_source_column @ 40 | input_source_id @ 41 | 6 ; 42 | 43 | : restore-input 44 | drop 45 | input_source_id ! 46 | input_source_column ! 47 | input_source_line ! 48 | input_buffer_size ! 49 | input_buffer_in ! 50 | input_buffer ! ; 51 | 52 | CREATE TIB video-width allot 53 | 54 | : interactive? source-id 0= ; 55 | 56 | : refill ( -- flag ) 57 | interactive? if 58 | TIB video-width accept 59 | refill-silent? @ not if space endif 60 | input_buffer_size ! 61 | TIB input_buffer ! 62 | >IN 0! 63 | true 64 | else 65 | false 66 | endif ; 67 | 68 | :noname 69 | refill-silent? @ not if 70 | space 71 | state @ if 72 | ." compiled" cr 73 | else 74 | ." ok" cr 75 | then 76 | endif 77 | refill drop 78 | ; tib_fill_routine ! 79 | 80 | : query 81 | input_source_id 0! 82 | refill drop ; 83 | 84 | : parse 85 | source drop >in @ + >r 86 | 0 swap 87 | begin dup parse-char <> while swap 1+ swap repeat 88 | drop r> swap ; 89 | 90 | : set-input-string ( addr u -- ) 91 | input_buffer_size ! 92 | input_buffer ! 93 | input_buffer_in 0! 94 | -1 input_source_id ! 95 | 1 input_source_line ! 96 | 0 input_source_column ! ; 97 | 98 | : execute-parsing ( ... addr u xt -- ... ) 99 | \ Save the input source to the control stack 100 | save-input dup begin dup 0 > while 1- rot >r repeat drop >r 101 | -rot set-input-string execute 102 | \ Restore the input source from the control stack 103 | r> dup begin dup 0 > while 1- r> -rot repeat drop 104 | restore-input ; 105 | 106 | 107 | \ Blocks 108 | variable blk? 109 | variable blk 110 | 111 | : b\ begin >IN @ 64 mod while parse-char drop repeat ; immediate 112 | : \ blk? @ if postpone b\ else postpone \ then ; immediate 113 | 114 | \ TODO: Not to use buffers to evaluate the blocks 115 | : load ( u -- ) 116 | blk? @ 117 | blk? on 118 | blk @ swap dup blk ! block 1024 evaluate blk ! 119 | blk? ! ; 120 | 121 | \ input.fs ends here 122 | -------------------------------------------------------------------------------- /interpreter.fs: -------------------------------------------------------------------------------- 1 | \ interpreter.fs 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | : octal 8 base ! ; 21 | : decimal 10 base ! ; 22 | : hex 16 base ! ; 23 | 24 | \ Directivas 25 | 26 | Defer [if] immediate 27 | Defer [else] immediate 28 | Defer [then] immediate 29 | 30 | ' [then] alias [endif] 31 | 32 | : read-word 33 | parse-nt dup 0<> if nt>xt then ; 34 | 35 | : lookup-else-or-then-1 36 | 0 >r 37 | begin 38 | read-word 39 | case 40 | ['] [if] of r> 1+ >r endof 41 | ['] [else] of 42 | r> 43 | ?dup 0= if 44 | exit 45 | else 46 | >r 47 | then 48 | endof 49 | ['] [then] of 50 | r> 51 | ?dup 0= if 52 | exit 53 | else 54 | 1- >r 55 | then 56 | endof 57 | endcase 58 | again 59 | ; 60 | 61 | : lookup-else-or-then 62 | not if lookup-else-or-then-1 endif 63 | ; latestxt IS [IF] 64 | 65 | : lookup-then 66 | 0 >r 67 | begin 68 | read-word 69 | case 70 | ['] [if] of r> 1+ >r endof 71 | ['] [then] of 72 | r> ?dup 0= if 73 | exit 74 | else 75 | 1- >r 76 | then 77 | endof 78 | endcase 79 | again 80 | ; latestxt IS [ELSE] 81 | 82 | ' noop IS [THEN] 83 | 84 | : [defined] parse-cname find-cname 0<> ; immediate 85 | : [ifdef] 86 | postpone [defined] 87 | postpone [if] 88 | ; immediate 89 | 90 | : [ifundef] 91 | postpone [defined] 92 | not 93 | postpone [if] 94 | ; immediate 95 | 96 | \ interpreters.fs ends here 97 | -------------------------------------------------------------------------------- /kernel/console.fs: -------------------------------------------------------------------------------- 1 | \ console.fs -- 2 | 3 | \ Copyright 2011, 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @structures.fs 21 | require @kernel/video.fs 22 | 23 | variable cursor-x 24 | variable cursor-y 25 | 26 | variable color-attr 27 | 28 | : attr color-attr @ ; 29 | : attr! color-attr ! ; 30 | 31 | : newline? ( ch -- flag ) 32 | case 33 | 10 of true endof 34 | 13 of true endof 35 | false swap 36 | endcase ; 37 | 38 | : last-line 39 | video-height 1- ; 40 | 41 | : at-end-on-line? 42 | cursor-x @ video-width = ; 43 | 44 | : at-last-line? 45 | cursor-y @ video-height = ; 46 | 47 | : update-hardware-cursor 48 | cursor-y @ 49 | cursor-x @ 50 | v-cursor-set-position ; 51 | 52 | : clear-char ( i j -- ) 53 | 2dup 54 | 32 -rot v-glyph! 55 | attr -rot v-attr! ; 56 | 57 | : clear-line ( i -- ) 58 | video-width 0 ?do 59 | dup i clear-char 60 | loop 61 | drop ; 62 | 63 | : clear-last-line 64 | last-line clear-line ; 65 | 66 | : scroll-one-line 67 | 1 0 v-offset \ from 68 | 0 0 v-offset \ to 69 | video-memsize video-width 2* - \ bytes 70 | move 71 | clear-last-line ; 72 | 73 | : emit-newline 74 | cursor-x 0! 75 | cursor-y 1+! ; 76 | 77 | : emit-char ( ch -- ) 78 | dup newline? if 79 | drop 80 | emit-newline 81 | else 82 | cursor-y @ cursor-x @ v-glyph! 83 | attr cursor-y @ cursor-x @ v-attr! 84 | cursor-x 1+! 85 | at-end-on-line? if emit-newline endif 86 | endif ; 87 | 88 | : scroll-if-required 89 | at-last-line? if 90 | cursor-x 0! 91 | video-height 1- cursor-y ! 92 | scroll-one-line 93 | then ; 94 | 95 | : emit ( ch -- ) 96 | emit-char scroll-if-required ; 97 | 98 | : at-xy ( column row ) 99 | cursor-y ! cursor-x ! ; 100 | 101 | : at-beginning 102 | 0 0 at-xy ; 103 | 104 | : at-beginning-of-line 105 | 0 cursor-y @ at-xy ; 106 | 107 | : at-end 108 | video-width 1- 109 | video-height 1- 110 | at-xy ; 111 | 112 | : page 113 | video-height 0 ?do 114 | i clear-line 115 | loop 116 | at-beginning ; 117 | 118 | 119 | : invert-screen 120 | video-width 0 ?do 121 | video-height 0 ?do 122 | i j v-attr@ invert i j v-attr! 123 | loop 124 | loop ; 125 | 126 | struct 127 | cell field screen-x 128 | cell field screen-y 129 | cell field screen-attr 130 | video-memsize chars field screen-buffer 131 | end-struct screen% 132 | 133 | : set-screen ( sid -- ) 134 | dup screen-x @ cursor-x ! 135 | dup screen-y @ cursor-y ! 136 | dup screen-attr @ color-attr ! 137 | screen-buffer video-addr video-memsize move 138 | update-hardware-cursor ; 139 | 140 | : save-screen ( -- sid ) 141 | screen% allocate throw 142 | cursor-x @ over screen-x ! 143 | cursor-y @ over screen-y ! 144 | video-addr over screen-buffer video-memsize move 145 | color-attr @ over screen-attr ! ; 146 | 147 | : restore-screen ( sid -- ) 148 | dup set-screen free throw ; 149 | 150 | PAGE 151 | 152 | \ console.fs ends here 153 | -------------------------------------------------------------------------------- /kernel/cpuid.fs: -------------------------------------------------------------------------------- 1 | \ cpuid.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | : toggle-bit-21 ( x -- y ) 21 | [ 1 21 lshift ]L xor ; 22 | 23 | eflags dup toggle-bit-21 eflags! 24 | eflags xor 21 bit? feature __CPUID__ 25 | 26 | [IFDEF] __CPUID__ 27 | : single-cpuid cpuid nip nip nip ; 28 | 29 | 0 cpuid 30 | constant highest-basic-value 31 | create vendor-id-string , , , 32 | 33 | : vendor-id 34 | vendor-id-string 12 ; 35 | 36 | vendor-id s" GenuineIntel" string= feature __INTEL__ 37 | 38 | 1 cpuid 39 | constant processor-signature 40 | constant processor-flag-ebx 41 | constant processor-flag-edx 42 | constant processor-flag-ecx 43 | 44 | processor-flag-ecx 0 bit? feature __SSE3__ 45 | processor-flag-ecx 1 bit? feature __PCLMULDQ__ 46 | processor-flag-ecx 2 bit? feature __DTES64__ 47 | processor-flag-ecx 3 bit? feature __MONITOR__ 48 | processor-flag-ecx 4 bit? feature __DS_CPL__ 49 | processor-flag-ecx 5 bit? feature __VMX__ 50 | processor-flag-ecx 6 bit? feature __SMX__ 51 | processor-flag-ecx 7 bit? feature __EIST__ 52 | processor-flag-ecx 8 bit? feature __TM2__ 53 | processor-flag-ecx 9 bit? feature __SSSE3__ 54 | processor-flag-ecx 10 bit? feature __CNXT_ID__ 55 | \ ...reserved... 56 | processor-flag-ecx 12 bit? feature __FMA__ 57 | processor-flag-ecx 13 bit? feature __CX16__ 58 | processor-flag-ecx 14 bit? feature __XTPR__ 59 | processor-flag-ecx 15 bit? feature __PDCM__ 60 | \ ...reserved... 61 | processor-flag-ecx 17 bit? feature __PCID__ 62 | processor-flag-ecx 18 bit? feature __DCA__ 63 | processor-flag-ecx 19 bit? feature __SSE_4_1__ 64 | processor-flag-ecx 20 bit? feature __SSE_4_2__ 65 | processor-flag-ecx 21 bit? feature __X2APIC__ 66 | processor-flag-ecx 22 bit? feature __MOVBE__ 67 | processor-flag-ecx 23 bit? feature __POPCNT__ 68 | processor-flag-ecx 24 bit? feature __TSC_DEADLINE__ 69 | processor-flag-ecx 25 bit? feature __AES__ 70 | processor-flag-ecx 26 bit? feature __XSAVE__ 71 | processor-flag-ecx 27 bit? feature __OSXSAVE__ 72 | processor-flag-ecx 28 bit? feature __AVX__ 73 | \ ...reserved... 74 | \ processor-flag-ecx 31 bit? feature __NO_USED__ 75 | 76 | processor-flag-edx 0 bit? feature __FPU__ 77 | processor-flag-edx 1 bit? feature __VME__ 78 | processor-flag-edx 2 bit? feature __DE__ 79 | processor-flag-edx 3 bit? feature __PSE__ 80 | processor-flag-edx 4 bit? feature __TSC__ 81 | processor-flag-edx 5 bit? feature __MSR__ 82 | processor-flag-edx 6 bit? feature __PAE__ 83 | processor-flag-edx 7 bit? feature __MCE__ 84 | processor-flag-edx 8 bit? feature __CX8__ 85 | processor-flag-edx 9 bit? feature __APIC__ 86 | \ ...reserved... 87 | processor-flag-edx 11 bit? feature __SEP__ 88 | processor-flag-edx 12 bit? feature __MTRR__ 89 | processor-flag-edx 13 bit? feature __PGE__ 90 | processor-flag-edx 14 bit? feature __MCA__ 91 | processor-flag-edx 15 bit? feature __CMOV__ 92 | processor-flag-edx 16 bit? feature __PAT__ 93 | processor-flag-edx 17 bit? feature __PSE_36__ 94 | processor-flag-edx 18 bit? feature __PSN__ 95 | processor-flag-edx 19 bit? feature __CLFSH__ 96 | \ ...reserved... 97 | processor-flag-edx 21 bit? feature __DS__ 98 | processor-flag-edx 22 bit? feature __ACPI__ 99 | processor-flag-edx 23 bit? feature __MMX__ 100 | processor-flag-edx 24 bit? feature __FXSR__ 101 | processor-flag-edx 25 bit? feature __SSE__ 102 | processor-flag-edx 26 bit? feature __SSE2__ 103 | processor-flag-edx 27 bit? feature __SS__ 104 | processor-flag-edx 28 bit? feature __HTT__ 105 | processor-flag-edx 29 bit? feature __TM__ 106 | \ ...reserved... 107 | processor-flag-edx 31 bit? feature __PBE__ 108 | 109 | [ENDIF] 110 | 111 | 112 | : cpuflags 113 | [ifdef] __SSE3__ ." sse3 " [then] 114 | [ifdef] __PCLMULDQ__ ." pclmuldq " [then] 115 | [ifdef] __DTES64__ ." dtes64 " [then] 116 | [ifdef] __MONITOR__ ." monitor " [then] 117 | [ifdef] __DS_CPL__ ." ds_cpl " [then] 118 | [ifdef] __VMX__ ." vmx " [then] 119 | [ifdef] __SMX__ ." smx " [then] 120 | [ifdef] __EIST__ ." eist " [then] 121 | [ifdef] __TM2__ ." tm2 " [then] 122 | [ifdef] __SSSE3__ ." ssse3 " [then] 123 | [ifdef] __CNXT_ID__ ." cnxt-id " [then] 124 | [ifdef] __FMA__ ." fma " [then] 125 | [ifdef] __CX16__ ." cx16 " [then] 126 | [ifdef] __XTPR__ ." xtpr " [then] 127 | [ifdef] __PDCM__ ." pdcm " [then] 128 | [ifdef] __PCID__ ." pcid " [then] 129 | [ifdef] __DCA__ ." dca " [then] 130 | [ifdef] __SSE_4_1__ ." sse_4_1 " [then] 131 | [ifdef] __SSE_4_2__ ." sse_4_2 " [then] 132 | [ifdef] __X2APIC__ ." x2apic " [then] 133 | [ifdef] __MOVBE__ ." movbe " [then] 134 | [ifdef] __POPCNT__ ." popcnt " [then] 135 | [ifdef] __TSC_DEADLINE__ ." tsc_deadline " [then] 136 | [ifdef] __AES__ ." aes " [then] 137 | [ifdef] __XSAVE__ ." xsave " [then] 138 | [ifdef] __OSXSAVE__ ." osxsave " [then] 139 | [ifdef] __AVX__ ." avx " [then] 140 | [ifdef] __FPU__ ." fpu " [then] 141 | [ifdef] __VME__ ." vme " [then] 142 | [ifdef] __DE__ ." de " [then] 143 | [ifdef] __PSE__ ." pse " [then] 144 | [ifdef] __TSC__ ." tsc " [then] 145 | [ifdef] __MSR__ ." msr " [then] 146 | [ifdef] __PAE__ ." pae " [then] 147 | [ifdef] __MCE__ ." mce " [then] 148 | [ifdef] __CX8__ ." cx8 " [then] 149 | [ifdef] __APIC__ ." apic " [then] 150 | [ifdef] __SEP__ ." sep " [then] 151 | [ifdef] __MTRR__ ." mtrr " [then] 152 | [ifdef] __PGE__ ." pge " [then] 153 | [ifdef] __MCA__ ." mca " [then] 154 | [ifdef] __CMOV__ ." cmov " [then] 155 | [ifdef] __PAT__ ." pat " [then] 156 | [ifdef] __PSE_36__ ." pse-36 " [then] 157 | [ifdef] __PSN__ ." psn " [then] 158 | [ifdef] __CLFSH__ ." clfsh " [then] 159 | [ifdef] __DS__ ." ds " [then] 160 | [ifdef] __ACPI__ ." acpi " [then] 161 | [ifdef] __MMX__ ." mmx " [then] 162 | [ifdef] __FXSR__ ." fxsr " [then] 163 | [ifdef] __SSE__ ." sse " [then] 164 | [ifdef] __SSE2__ ." sse2 " [then] 165 | [ifdef] __SS__ ." ss " [then] 166 | [ifdef] __HTT__ ." htt " [then] 167 | [ifdef] __TM__ ." tm " [then] 168 | [ifdef] __PBE__ ." pbe " [then] 169 | ; 170 | 171 | : cpuinfo 172 | cr 173 | ." Vendor-ID: " vendor-id type cr 174 | ." Flags : " cpuflags cr 175 | ; 176 | 177 | \ cpuids.fs ends here 178 | -------------------------------------------------------------------------------- /kernel/exceptions.fs: -------------------------------------------------------------------------------- 1 | \ exceptions.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @kernel/interrupts.fs 21 | 22 | : ISR latestxt isr-register ; 23 | 24 | : fatal-exception ( isrinfo-addr ) 25 | ." Interrupt #" 26 | dup isrinfo-int-no ? 27 | ." with error code " 28 | dup isrinfo-err-code @ print-hex-number 29 | ." ." cr 30 | ." EAX = " dup isrinfo-eax @ print-hex-number cr 31 | ." ECX = " dup isrinfo-ecx @ print-hex-number cr 32 | ." EDX = " dup isrinfo-edx @ print-hex-number cr 33 | ." EBX = " dup isrinfo-ebx @ print-hex-number cr 34 | ." EBP = " dup isrinfo-ebp @ print-hex-number cr 35 | ." ESI = " dup isrinfo-esi @ print-hex-number cr 36 | ." EDI = " dup isrinfo-edi @ print-hex-number cr 37 | ." ESP = " dup isrinfo-useresp @ print-hex-number cr 38 | ." EIP = " dup isrinfo-eip @ print-hex-number cr 39 | ." CS = " dup isrinfo-cs @ print-hex-number cr 40 | ." EFLAGS = " dup isrinfo-eflags @ print-hex-number cr 41 | ." SS = " dup isrinfo-ss @ print-hex-number cr 42 | drop 43 | disable-interrupts 44 | backtrace 45 | halt ; 46 | 47 | : division-by-zero-exception ( isrinfo-addr ) 48 | isrinfo-eflags @ eflags! 49 | -10 throw 50 | ; 0 ISR 51 | 52 | \ : debug-exception 53 | \ fatal-exception 54 | \ ; 1 ISR 55 | 56 | : non-maskable-interrupt-exception 57 | fatal-exception 58 | ; 2 ISR 59 | 60 | \ : breakpoint-exception 61 | \ fatal-exception 62 | \ ; 3 ISR 63 | 64 | : overflow-exception 65 | fatal-exception 66 | ; 4 ISR 67 | 68 | : out-of-bounds-exception 69 | fatal-exception 70 | ; 5 ISR 71 | 72 | : invalid-opcode-exception 73 | fatal-exception 74 | ; 6 ISR 75 | 76 | : no-coprocessor-exception 77 | fatal-exception 78 | ; 7 ISR 79 | 80 | : double-fault-exception 81 | fatal-exception 82 | ; 8 ISR 83 | 84 | : coprocessor-segment-overrun-exception 85 | fatal-exception 86 | ; 9 ISR 87 | 88 | : tss-exception 89 | fatal-exception 90 | ; 10 ISR 91 | 92 | : segment-not-present-exception 93 | fatal-exception 94 | ; 11 ISR 95 | 96 | : stack-fault-excetion 97 | fatal-exception 98 | ; 12 ISR 99 | 100 | : general-protection-fault-exception 101 | fatal-exception 102 | ; 13 ISR 103 | 104 | : page-fault-exception 105 | fatal-exception 106 | ; 14 ISR 107 | 108 | : unknown-interrupt-exception 109 | fatal-exception 110 | ; 15 ISR 111 | 112 | : coprocessor-fault-exception 113 | fatal-exception 114 | ; 16 ISR 115 | 116 | : alignment-check-exception ( 486+ ) 117 | fatal-exception 118 | ; 17 ISR 119 | 120 | : machine-check-exception ( Pentium/586+ ) 121 | fatal-exception 122 | ; 18 ISR 123 | 124 | : reserved-exception 125 | fatal-exception 126 | ; 127 | 19 ISR 20 ISR 21 ISR 128 | 22 ISR 23 ISR 24 ISR 129 | 25 ISR 26 ISR 27 ISR 130 | 28 ISR 29 ISR 30 ISR 131 | 31 ISR 132 | 133 | \ exceptions.fs ends here 134 | -------------------------------------------------------------------------------- /kernel/floppy.fs: -------------------------------------------------------------------------------- 1 | \ floppy.fs -- 2 | 3 | \ Copyright 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ TODO: It is missing error checking and retries, so it will not work 21 | \ on real hardware however I have not a real machine with floppy drive 22 | \ to test it properly. 23 | 24 | require @structures.fs 25 | require @kernel/timer.fs 26 | 27 | \ Registers 28 | : MSR $3F4 inputb ; 29 | : DOR $3F2 inputb ; : DOR! $3F2 outputb ; 30 | : FIFO $3F5 inputb ; : FIFO! $3F5 outputb ; 31 | : CCR! $3F7 outputb ; 32 | 33 | \ ready to read/write? 34 | : RQM MSR $80 and ; 35 | 36 | \ Motors 37 | variable turn? 38 | : turn-on 39 | turn? @ not if DOR $10 or DOR! 300 ms turn? on then 40 | TIMER0 reset-timer ; 41 | 42 | : turn-off 43 | turn? @ if DOR [ $10 invert ]L and DOR! turn? off then ; 44 | 45 | \ Commands 46 | 512 constant BPS \ bytes per sector 47 | 18 constant SPT \ sectors per track 48 | BPS SPT * 2 * constant BPC \ bytes per cylinder 49 | 50 | true constant device>memory 51 | false constant memory>device 52 | 53 | : reset-floppy 54 | $00 DOR! $0C DOR! ; 55 | 56 | variable irq6-received 57 | : _wait-irq ( -- ) \ throws error 5 on timeout, defaulting to stopping the word unless a catch is implimented 58 | time 4000 + begin dup time <= if 5 throw then irq6-received @ not while halt repeat drop ; 59 | 60 | : wait-irq ( -- ) \ wrapper for old wait-irq that resets the controller on timeout 61 | ['] _wait-irq catch 62 | case 63 | 5 of reset-floppy endof 64 | dup throw 65 | endcase ; 66 | 67 | : wait-ready 68 | 128 0 ?do RQM if unloop exit endif 10 ms loop ; 69 | 70 | : read-data wait-ready FIFO ; 71 | : write-data wait-ready FIFO! ; 72 | 73 | : command irq6-received off write-data ; 74 | ' write-data alias >> 75 | ' read-data alias << 76 | 77 | : specify ( -- ) 78 | $03 command $df >> $02 >> ; 79 | 80 | : version ( -- x ) 81 | $10 command << ; 82 | 83 | : sense-interrupt ( -- st0 cyl ) 84 | $08 command << << ; 85 | 86 | : seek ( cylinder -- ) 87 | $0f command 0 >> >> wait-irq ; 88 | 89 | : recalibrate 90 | $07 command $00 >> wait-irq ; 91 | 92 | : xfer-ask ( s h c direction -- ) 93 | device>memory = if $c6 else $c5 then command 94 | over 2 lshift >> 95 | ( c ) >> ( h ) >> ( s ) >> 96 | 2 >> 18 >> $1b >> $ff >> ; 97 | 98 | : xfer-vry ( -- st0 st1 st2 c h s ) 99 | << << << << << << << ( 2 ) drop ; 100 | 101 | : read ( c h s --- st0 st1 c h s ) 102 | swap rot device>memory xfer-ask wait-irq xfer-vry ; 103 | 104 | : write ( c h s --- st0 st1 c h s ) 105 | swap rot memory>device xfer-ask wait-irq xfer-vry ; 106 | 107 | 108 | \ ISA-DMA 109 | 110 | BPC constant dma-buffer-size 111 | 112 | \ Align the dictionary to get a good buffer to do ISA DMA. The 113 | \ conditions are: below 64MB and not to cross a 64KB boundary. 114 | align 115 | dp dma-buffer-size + dp $ffff or > [if] 116 | dp $ffff + $ffff0000 and dp! 117 | [endif] 118 | $01000000 here u<= [if] 119 | attr light red ." FATAL: ISA DMA Buffer is not below 64MB." cr attr! 120 | halt 121 | [endif] 122 | 123 | here dma-buffer-size allot constant dma-buffer 124 | ' dma-buffer alias floppy-buffer 125 | 126 | : flip-flop 127 | $ff $0c outputb ; 128 | 129 | : dma-setup ( size -- ) 130 | flip-flop 131 | dma-buffer ( 0 rshift ) $04 outputb 132 | dma-buffer 8 rshift $04 outputb 133 | dma-buffer 16 rshift $81 outputb 134 | flip-flop 135 | 1- dup $05 outputb 136 | 8 rshift $05 outputb ; 137 | 138 | \ Setup DMA-BUFFER to a operation of reading of U bytes. Note that a 139 | \ value of zero means $FFFF bytes. 140 | : dma-read ( u -- ) 141 | disable-interrupts 142 | $06 $0a outputb 143 | dma-setup 144 | $46 $0b outputb 145 | $02 $0a outputb 146 | enable-interrupts ; 147 | 148 | \ Setup DMA-BUFFER to a operation of writing of U bytes. Note that a 149 | \ value of zero means $FFFF bytes. 150 | : dma-write ( u -- ) 151 | disable-interrupts 152 | $06 $0a outputb 153 | dma-setup 154 | $4a $0b outputb 155 | $02 $0a outputb 156 | enable-interrupts ; 157 | 158 | 159 | \ Transfers 160 | 161 | : dma>addr ( addr u -- ) 162 | dma-buffer -rot move ; 163 | 164 | : addr>dma ( addr u -- ) 165 | dma-buffer swap move ; 166 | 167 | : read-sectors ( c h s u -- ) 168 | turn-on 169 | BPS * dma-read 170 | -rot dup seek rot 171 | sense-interrupt 2drop 172 | read 2drop 2drop 2drop ; 173 | 174 | : write-sectors ( c h s u -- ) 175 | turn-on 176 | BPS * dma-write 177 | -rot dup seek rot 178 | sense-interrupt 2drop 179 | write 2drop 2drop 2drop ; 180 | 181 | : read-cylinder ( c -- ) 182 | 0 1 SPT 2* read-sectors ; 183 | 184 | : write-cylinder ( c -- ) 185 | 0 1 SPT 2* write-sectors ; 186 | 187 | 188 | 189 | : detect-drive ( -- flag ) 190 | $10 $70 outputb $71 inputb 4 rshift 4 = ; 191 | 192 | : setup-floppy 193 | $00 CCR! ; 194 | 195 | : irq-floppy 196 | irq6-received on 197 | ; 6 IRQ 198 | 199 | : initialize-floppy 200 | detect-drive not if exit then 201 | 2000 ['] turn-off TIMER0 set-timer 202 | irq6-received off 203 | reset-floppy 204 | wait-irq 205 | sense-interrupt 2drop 206 | setup-floppy 207 | specify 208 | turn-on 209 | recalibrate 210 | sense-interrupt 2drop 211 | turn-off ; 212 | 213 | : floppy-read-sectors ( addr u c h s -- ) 214 | 3 pick read-sectors 512 * dma>addr ; 215 | 216 | : floppy-write-sectors ( addr u c h s -- ) 217 | 3 pick >r >r >r >r 512 * addr>dma 218 | r> r> r> r> write-sectors ; 219 | 220 | : lba ( lba -- c h s ) 221 | dup SPT 2* / 222 | over SPT 2* mod SPT / 223 | rot SPT mod 1+ ; 224 | 225 | \ floppy.fs ends here 226 | -------------------------------------------------------------------------------- /kernel/interrupts.fs: -------------------------------------------------------------------------------- 1 | \ interrupts.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @vocabulary.fs 21 | require @structures.fs 22 | 23 | ' cli alias disable-interrupts 24 | ' sti alias enable-interrupts 25 | 26 | \ INTERRUPT DESCRIPTOR TABLE (IDT) 27 | 28 | \ An integer from 32 to 256 which specify how many entries will have 29 | \ the interrupt descriptor table. Set this variable correctly to hold 30 | \ exceptions and IRQs. 31 | 48 constant idt-n-entries 32 | 33 | struct 34 | 16bits field idt-entry-base-low 35 | 16bits field idt-entry-sel 36 | 8bits field idt-entry-zero 37 | 8bits field idt-entry-flags 38 | 16bits field idt-entry-base-high 39 | end-struct idt-entry% 40 | 41 | idt-entry% idt-n-entries * constant idt-size 42 | gdt-cs-selector constant selector 43 | create idt-table idt-size zallot 44 | 45 | : low-word $FFFF and ; 46 | : high-word 16 rshift low-word ; 47 | 48 | : flush-idt 49 | idt-table idt-size 1- lidt ; 50 | 51 | : write-isr-to-idt ( num addr flags -- ) 52 | >r >r 53 | idt-entry% * idt-table + 54 | r@ high-word over idt-entry-base-high w! 55 | r> low-word over idt-entry-base-low w! 56 | 0 over idt-entry-zero c! 57 | selector over idt-entry-sel w! 58 | r> swap idt-entry-flags c! 59 | ; 60 | 61 | \ Interrupt service routines (ISR) 62 | \ 63 | \ ISRs cannot be written in Forth easily because we cannot handle how 64 | \ the state of the machine change. Some of the more primitive parts 65 | \ like CREATE..DOES> would become inmutable. Indeed, we write this 66 | \ code in native code directly, using some auxiliary words because we 67 | \ are missing an assembler. 68 | 69 | struct 70 | \ Pushed by PUSHA 71 | 32bits field isrinfo-edi 72 | 32bits field isrinfo-esi 73 | 32bits field isrinfo-ebp 74 | 32bits field isrinfo-esp 75 | 32bits field isrinfo-ebx 76 | 32bits field isrinfo-edx 77 | 32bits field isrinfo-ecx 78 | 32bits field isrinfo-eax 79 | \ Interrupt number and error code 80 | 32bits field isrinfo-int-no 81 | 32bits field isrinfo-err-code 82 | \ Pushed by the processor automatically. 83 | 32bits field isrinfo-eip 84 | 32bits field isrinfo-cs 85 | 32bits field isrinfo-eflags 86 | 32bits field isrinfo-useresp 87 | 32bits field isrinfo-ss 88 | end-struct isrinfo% 89 | 90 | \ A table of high level interrupt service routines written in normal 91 | \ Forth. The routine ISR-DISPATCHER will dispatch to the right ISR 92 | \ according to this table. 93 | create isr-table idt-n-entries cells allot 94 | 95 | : int>handler-slot 96 | cells isr-table + ; 97 | : get-isr ( int -- handler ) 98 | int>handler-slot @ ; 99 | : set-isr ( int handler -- ) 100 | swap int>handler-slot ! ; 101 | : isr-execute ( int -- ... ) 102 | get-isr execute ; 103 | 104 | : isr-dispatcher 105 | rsp cell + 106 | dup isrinfo-int-no @ isr-execute ; 107 | 108 | ( Hide the ISR words to the system. They should not be called 109 | from other Forth words because they use a different call convention. ) 110 | WORDLIST >ORDER DEFINITIONS 111 | 112 | : cli $fa c, ; 113 | : sti $fb c, ; 114 | : pusha $60 c, ; 115 | : popa $61 c, ; 116 | : iret $cf c, ; 117 | : call $e8 c, here 4 + - , ; 118 | : jmp $e9 c, here 4 + - , ; \ jmp X 119 | : push-rstack 120 | \ push $N 121 | $68 c, , ; 122 | : unwind-rstack 123 | \ addl $N, %esp 124 | $83 c, $c4 c, c, ; 125 | 126 | CREATE isr-stub 127 | pusha 128 | ' isr-dispatcher call 129 | popa 130 | 8 unwind-rstack 131 | iret 132 | 133 | : ISR-ERRCODE ( n -- n addr ) 134 | here over 135 | push-rstack 136 | isr-stub jmp ; 137 | 138 | : ISR-NOERRCODE ( n -- n addr ) 139 | here over 140 | 0 push-rstack 141 | push-rstack 142 | isr-stub jmp ; 143 | 144 | : ;; $8e write-isr-to-idt ; 145 | 146 | DISABLE-INTERRUPTS 147 | 148 | 00 ISR-NOERRCODE ;; \ Division By Zero Exception 149 | 01 ISR-NOERRCODE ;; \ Debug Exception 150 | 02 ISR-NOERRCODE ;; \ Non Maskable Interrupt Exception 151 | 03 ISR-NOERRCODE ;; \ Breakpoint Exception 152 | 04 ISR-NOERRCODE ;; \ Into Detected Overflow Exception 153 | 05 ISR-NOERRCODE ;; \ Out of Bounds Exception 154 | 06 ISR-NOERRCODE ;; \ Invalid Opcode Exception 155 | 07 ISR-NOERRCODE ;; \ No Coprocessor Exception 156 | 08 ISR-ERRCODE ;; \ Double Fault Exception 157 | 09 ISR-NOERRCODE ;; \ Coprocessor Segment Overrun Exception 158 | 10 ISR-ERRCODE ;; \ Bad TSS Exception 159 | 11 ISR-ERRCODE ;; \ Segment Not Present Exception 160 | 12 ISR-ERRCODE ;; \ Stack Fault Exception 161 | 13 ISR-ERRCODE ;; \ General Protection Fault Exception 162 | 14 ISR-ERRCODE ;; \ Page Fault Exception 163 | 15 ISR-NOERRCODE ;; \ Unknown Interrupt Exception 164 | 16 ISR-NOERRCODE ;; \ Coprocessor Fault Exception 165 | 17 ISR-NOERRCODE ;; \ Alignment Check Exception (486+) 166 | 18 ISR-NOERRCODE ;; \ Machine Check Exception (Pentium/586+) 167 | 19 ISR-NOERRCODE ;; \ Reserved 168 | 20 ISR-NOERRCODE ;; \ Reserved 169 | 21 ISR-NOERRCODE ;; \ Reserved 170 | 22 ISR-NOERRCODE ;; \ Reserved 171 | 23 ISR-NOERRCODE ;; \ Reserved 172 | 24 ISR-NOERRCODE ;; \ Reserved 173 | 25 ISR-NOERRCODE ;; \ Reserved 174 | 26 ISR-NOERRCODE ;; \ Reserved 175 | 27 ISR-NOERRCODE ;; \ Reserved 176 | 28 ISR-NOERRCODE ;; \ Reserved 177 | 29 ISR-NOERRCODE ;; \ Reserved 178 | 30 ISR-NOERRCODE ;; \ Reserved 179 | 31 ISR-NOERRCODE ;; \ Reserved 180 | 181 | FLUSH-IDT 182 | ALSO FORTH-IMPL DEFINITIONS 183 | 184 | : isr-register ( n addr ) 185 | 2dup set-isr 186 | drop dup 31 > if 187 | \ Write low level ISR to the IDT 188 | ISR-NOERRCODE ;; 189 | else drop then 190 | ; 191 | 192 | PREVIOUS 193 | PREVIOUS 194 | 195 | \ interrupts.fs ends here 196 | -------------------------------------------------------------------------------- /kernel/irq.fs: -------------------------------------------------------------------------------- 1 | \ irq.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @kernel/interrupts.fs 21 | 22 | \ PROGRAMMABLE INTERRUPT CONTROLLER (PIC) 23 | $20 constant picm-command 24 | $21 constant picm-data 25 | $A0 constant pics-command 26 | $A1 constant pics-data 27 | 28 | : send-picm picm-command outputb io-wait ; 29 | : send-pics pics-command outputb io-wait ; 30 | : send-picm-data picm-data outputb io-wait ; 31 | : send-pics-data pics-data outputb io-wait ; 32 | : read-picm-data picm-data inputb ; 33 | : read-pics-data pics-data inputb ; 34 | 35 | : slave-irq? 8 >= ; 36 | 37 | : send-eoi ( irq -- ) 38 | slave-irq? if $20 send-pics then 39 | $20 send-picm ; 40 | 41 | 42 | \ Master PIC IRQs 43 | $20 44 | enum irq0 \ System timer 45 | enum irq1 \ keyboard controller 46 | enum irq2 \ IRQ9 47 | enum irq3 \ Serial port controller for COM2 (shared with COM4, if present) 48 | enum irq4 \ Serial port controller for COM1 (shared with COM3, if present) 49 | enum irq5 \ LPT port 2 or sound card 50 | enum irq6 \ Floppy disk controller 51 | enum irq7 \ LPT port 1 52 | \ Slave PIC IRQs 53 | enum irq8 \ RTC Timer 54 | enum irq9 \ The Interrupt is left open for the use of peripherals 55 | enum irq10 \ The Interrupt is left open for the use of peripherals 56 | enum irq11 \ The Interrupt is left open for the use of peripherals 57 | enum irq12 \ Mouse on PS/2 connector 58 | enum irq13 \ Math co-processor or integrated floating point unit 59 | enum irq14 \ Primary ATA channel 60 | enum irq15 \ Secondary ATA channel 61 | end-enum 62 | 63 | $01 constant ICW1-ICW4 64 | $10 constant ICW1-INIT 65 | $01 constant ICW4-8086 66 | 67 | : IRM1 read-picm-data ; 68 | : IRM1! send-picm-data ; 69 | : IRM2 read-pics-data ; 70 | : IRM2! send-picm-data ; 71 | 72 | : save-irq-masks 73 | IRM1 IRM2 ; 74 | 75 | : restore-irq-masks 76 | IRM2! IRM1! ; 77 | 78 | : remap-master-irq ( offset -- ) 79 | >r 80 | save-irq-masks 81 | ICW1-INIT ICW1-ICW4 + send-picm 82 | r> send-picm-data 83 | 4 send-picm-data 84 | ICW4-8086 send-picm-data 85 | restore-irq-masks ; 86 | 87 | : remap-slave-irq ( offset -- ) 88 | >r 89 | save-irq-masks 90 | ICW1-INIT ICW1-ICW4 + send-pics 91 | r> send-pics-data 92 | 2 send-pics-data 93 | ICW4-8086 send-pics-data 94 | restore-irq-masks ; 95 | 96 | : bit 1 swap lshift ; 97 | 98 | : irq-mask ( irq -- ) 99 | dup slave-irq? if 100 | 8 - bit IRM2 or IRM2! 101 | else 102 | bit IRM1 or IRM1! 103 | endif ; 104 | 105 | : irq-unmask ( irq -- ) 106 | dup slave-irq? if 107 | 8 - bit not IRM2 and IRM2! 108 | else 109 | bit not IRM1 and IRM1! 110 | endif ; 111 | 112 | : irq-disable irq-mask ; 113 | : irq-enable irq-unmask ; 114 | 115 | 116 | \ Remap IRQs 117 | IRQ0 REMAP-MASTER-IRQ 118 | IRQ8 REMAP-SLAVE-IRQ 119 | 120 | : CREATE-IRQ ( xt n -- ) 121 | noname create swap , , does> 122 | dup @ execute 123 | cell + @ send-eoi ; 124 | 125 | : IRQ ( n -- ) 126 | latestxt over CREATE-IRQ 127 | irq0 + latestxt isr-register ; 128 | 129 | : unhandled-irq 130 | drop 131 | ; 0 IRQ 1 IRQ 2 IRQ 3 IRQ 132 | 4 IRQ 5 IRQ 6 IRQ 7 IRQ 133 | 8 IRQ 9 IRQ 10 IRQ 11 IRQ 134 | 12 IRQ 13 IRQ 14 IRQ 15 IRQ 135 | 136 | 0 IRQ-UNMASK 137 | 138 | \ irq.fs ends here 139 | -------------------------------------------------------------------------------- /kernel/keyboard.fs: -------------------------------------------------------------------------------- 1 | \ keyboard.fs --- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @kernel/irq.fs 21 | 22 | $5e constant kbd-intrfc 23 | $60 constant kbd-port 24 | $64 constant kbd-io 25 | $fe constant kdb-reset 26 | 27 | : clear-kbd-buffer 28 | begin 29 | kbd-intrfc inputb 30 | dup 0 bit? if drop kbd-io inputb then 31 | 1 bit? false = until ; 32 | 33 | : kbd-scancode 34 | kbd-port inputb ; 35 | 36 | 37 | 64 constant kbdbuff-size 38 | create kbdbuff kbdbuff-size allot 39 | variable kbdbuff-wp 40 | variable kbdbuff-rp 41 | 42 | : kbdp++ ( ptr -- ) 43 | dup @ 1+ kbdbuff-size mod swap ! ; 44 | : kbdbuff-empty? 45 | kbdbuff-rp @ 46 | kbdbuff-wp @ = ; 47 | : kbdbuff-full? 48 | kbdbuff-wp @ 1+ kbdbuff-size mod 49 | kbdbuff-rp @ = ; 50 | 51 | : irq1-keyboard 52 | \ This word is marked as IRQ handler, and therefore it is called 53 | \ by the FLIH with interrupts disabled, so that we can grant the 54 | \ atomicity of this routine. 55 | kbdbuff-full? if kbdbuff-rp kbdp++ then 56 | kbd-scancode kbdbuff-wp @ kbdbuff + c! 57 | kbdbuff-wp kbdp++ 58 | ; 1 IRQ 59 | 60 | 61 | : scancode? ( -- flag ) 62 | kbdbuff-empty? not ; 63 | 64 | : wait-scancode 65 | begin scancode? not while halt repeat ; 66 | 67 | : discard-scancode 68 | kbdbuff-rp kbdp++ ; 69 | 70 | : peek-scancode ( -- sc ) 71 | wait-scancode 72 | kbdbuff-rp @ kbdbuff + c@ ; 73 | 74 | : scancode ( -- sc ) 75 | peek-scancode 76 | discard-scancode ; 77 | 78 | : flush-scancode 79 | begin scancode? while discard-scancode repeat ; 80 | 81 | 82 | \ Scancodes interpretation. SET1 (IBM PC XT) 83 | 84 | \ This code is non-extensible and incomplete. We handle very basic 85 | \ keys with alt, shift and ctrl as modifiers. It is enough for me 86 | \ since I will use an emacs-like keybindings. However, feel free to 87 | \ write it! 88 | 89 | 08 constant TAB 90 | 10 constant RET 91 | 32 constant ______SPACE______ 92 | 93 | \ Non-implemented keys. 94 | 00 constant CAPSLOCK 95 | 00 constant NUMLOCK 96 | 97 | $80 98 | enum ESC enum BACK enum DEL 99 | enum CTRL enum SHIFT enum PRSCR 100 | enum ALT ( enum CAPSLOCK ) enum F1 101 | enum F2 enum F3 enum F4 102 | enum F5 enum F6 enum F7 103 | enum F8 enum F9 enum F10 104 | enum F11 enum F12 ( enum NUMLOCK ) 105 | enum SCRLOCK enum HOME enum UP 106 | enum LEFT enum RIGHT enum DOWN 107 | enum PGUP enum PGDOWN enum END 108 | enum INSRT 109 | end-enum 110 | 111 | \ The layout is according to the original IBM Personal Computer. 112 | 113 | \ These tables translate scancodes to an internal representation for 114 | \ keystrokes, which is a superset of ASCII. 115 | 116 | : TBLSC-SPECIAL 117 | F1 c, F2 c, F3 c, F4 c, F5 c, F6 c, F7 c, F8 c, F9 c, F10 c, 118 | 00 c, 00 c, 00 c, UP c, 119 | 00 c, 00 c, LEFT c, 00 c, RIGHT c, 120 | ( ) 00 c, 00 c, DOWN c, 121 | ; 122 | 123 | : | char c, ; 124 | 125 | \ \ Like allot but initialize with zero the memory. 126 | : zallot ( n -- ) 127 | here >r dup allot r> 128 | swap 0 fill ; 129 | 130 | : tblsize here swap - ; 131 | 132 | : end. tblsize 256 swap - zallot ; 133 | 134 | 135 | CREATE TBLSC-QWERTY 136 | ( ) 137 | ( ) 0 c, ESC c, 138 | ( ) | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 0 | - | = BACK c, 139 | ( ) TAB c, | q | w | e | r | t | y | u | i | o | p | [ | ] RET c, 140 | ( ) CTRL c, | a | s | d | f | g | h | j | k | l | ; | ' | ` 141 | ( ) SHIFT c, | \ | z | x | c | v | b | n | m | , | . | / SHIFT c, 142 | ( ) PRSCR c, ALT c, ______SPACE______ c, CAPSLOCK c, 143 | ( ) 144 | ( ) TBLSC-SPECIAL 145 | ( ) 146 | TBLSC-QWERTY END. 147 | 148 | CREATE TBLSC-QWERTY-SHIFT 149 | ( ) 150 | ( ) 0 c, ESC c, 151 | ( ) | ! | @ | # | $ | % | ^ | & | * | ( | ) | _ | + BACK c, 152 | ( ) TAB c, | Q | W | E | R | T | Y | U | I | O | P | { | } RET c, 153 | ( ) CTRL c, | A | S | D | F | G | H | J | K | L | : | " | ~ 154 | ( ) SHIFT c, | | | Z | X | C | V | B | N | M | < | > | ? SHIFT c, 155 | ( ) PRSCR c, ALT c, ______SPACE______ c, CAPSLOCK c, 156 | ( ) 157 | ( ) TBLSC-SPECIAL 158 | ( ) 159 | TBLSC-QWERTY-SHIFT END. 160 | 161 | CREATE TBLSC-DVORAK 162 | ( ) 163 | ( ) 0 c, ESC c, 164 | ( ) | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 0 | [ | ] BACK c, 165 | ( ) TAB c, | ' | , | . | p | y | f | g | c | r | l | / | = RET c, 166 | ( ) CTRL c, | a | o | e | u | i | d | h | t | n | s | - | \ 167 | ( ) SHIFT c, | ; | ; | q | j | k | x | b | m | w | v | z SHIFT c, 168 | ( ) PRSCR c, ALT c, ______SPACE______ c, CAPSLOCK c, 169 | ( ) 170 | ( ) TBLSC-SPECIAL 171 | ( ) 172 | TBLSC-DVORAK END. 173 | 174 | CREATE TBLSC-DVORAK-SHIFT 175 | ( ) 176 | ( ) 0 c, ESC c, 177 | ( ) | ! | @ | # | $ | % | ^ | & | * | ( | ) | _ | + BACK c, 178 | ( ) TAB c, | " | < | > | P | Y | F | G | C | R | L | ? | + RET c, 179 | ( ) CTRL c, | A | O | E | U | I | D | H | T | N | S | _ | | 180 | ( ) SHIFT c, | : | : | Q | J | K | X | B | M | W | V | Z SHIFT c, 181 | ( ) PRSCR c, ALT c, ______SPACE______ c, CAPSLOCK c, 182 | ( ) 183 | ( ) TBLSC-SPECIAL 184 | ( ) 185 | TBLSC-DVORAK-SHIFT END. 186 | 187 | : QWERTY ['] TBLSC-QWERTY ['] TBLSC-QWERTY-SHIFT ; 188 | : DVORAK ['] TBLSC-DVORAK ['] TBLSC-DVORAK-SHIFT ; 189 | 190 | DEFER TBLSC 191 | DEFER TBLSC-SHIFT 192 | 193 | : setxkmap ( tblsc-addr tblsc-shift-addr ) 194 | IS TBLSC-SHIFT 195 | IS TBLSC ; 196 | 197 | variable alt-level 198 | variable ctrl-level 199 | variable shift-level 200 | 201 | : shift? 0 shift-level @ < ; 202 | : ctrl? 0 ctrl-level @ < ; 203 | : alt? 0 alt-level @ < ; 204 | 205 | : break? ( sc -- flag ) 7 bit? ; 206 | : make? ( sc -- flag ) break? not ; 207 | : ->make $7f and ; 208 | 209 | \ Retrieve a possibly prefixed scancode and yield two cells in the 210 | \ stack. If the scancode is not prefixed, prefix is 0. 211 | : pkey ( -- prefix sc ) 212 | scancode dup $e0 = if scancode else 0 swap endif ; 213 | 214 | \ Decompound a scancode as a 'make' scancode more a flag which 215 | \ indicates if it is a make or a break scancode. 216 | : rkey ( -- prefix sc make? ) 217 | pkey dup make? swap ->make swap ; 218 | 219 | : sc->ekey ( sc -- key ) 220 | shift? if tblsc-shift + c@ else tblsc + c@ endif ; 221 | 222 | : bool->sign ( flag -- +1\-1 ) 223 | if 1 else -1 endif ; 224 | 225 | \ Update special keys according to SC and MAKE?. If SC is a special 226 | \ key, it will be replaced by a null scancode. 227 | : process-special-keys ( sc make? -- sc|0 make? ) 228 | over sc->ekey case 229 | SHIFT of dup bool->sign shift-level +! nip 0 swap endof 230 | CTRL of dup bool->sign ctrl-level +! nip 0 swap endof 231 | ALT of dup bool->sign alt-level +! nip 0 swap endof 232 | endcase ; 233 | 234 | 235 | $1 constant shift-mod 236 | $2 constant ctrl-mod 237 | $4 constant alt-mod 238 | 239 | : modifier ( -- modifiers ) 240 | 0 ( no modifiers ) 241 | shift? if shift-mod or then 242 | ctrl? if ctrl-mod or then 243 | alt? if alt-mod or then ; 244 | 245 | : ekey* 246 | begin 247 | rkey rot drop \ Ignore prefix 248 | process-special-keys 249 | ( make? ) if 250 | sc->ekey ?dup if exit endif 251 | else 252 | drop 253 | endif 254 | again ; 255 | 256 | : ekey ( -- key modifier ) 257 | ekey* modifier ; 258 | 259 | : key begin ekey* $80 over <= while drop repeat ; 260 | 261 | \ keyboard.fs ends here 262 | -------------------------------------------------------------------------------- /kernel/multiboot.fs: -------------------------------------------------------------------------------- 1 | \ multiboot.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ Transcription of multiboot.h from FSF to Forth 21 | 22 | $1BADB002 constant multiboot-header-magic 23 | $2BADB002 constant multiboot-bootloader-magic 24 | 25 | struct 26 | 32bits field multiboot-header-magic 27 | 32bits field multiboot-header-flags 28 | 32bits field multiboot-header-checksum 29 | 32bits field multiboot-header-header-addr 30 | 32bits field multiboot-header-load-addr 31 | 32bits field multiboot-header-load-end-addr 32 | 32bits field multiboot-header-bss-end-addr 33 | 32bits field multiboot-header-bss-entry-addr 34 | end-struct multiboot-header% 35 | 36 | struct 37 | 32bits field aout-symbol-table-tabsize 38 | 32bits field aout-symbol-table-strsize 39 | 32bits field aout-symbol-table-addr 40 | 32bits field aout-symbol-table-reserved 41 | end-struct aout-symbol-table% 42 | 43 | struct 44 | 32bits field elf-section-header-table-num 45 | 32bits field elf-section-header-table-size 46 | 32bits field elf-section-header-table-addr 47 | 32bits field elf-section-header-table-shndx 48 | end-struct elf-section-header-table% 49 | 50 | \ The Multiboot information 51 | struct 52 | 32bits field multiboot-info-flags 53 | 32bits field multiboot-info-mem-lower 54 | 32bits field multiboot-info-mem-upper 55 | 32bits field multiboot-info-boot-device 56 | 32bits field multiboot-info-cmdline 57 | 32bits field multiboot-info-mods-count 58 | 32bits field multiboot-info-mods-addr 59 | \ The union of the structures 60 | elf-section-header-table% aout-symbol-table% max field multiboot-info-u 61 | 32bits field multiboot-info-mmap-length 62 | 32bits field multiboot-info-mmap-addr 63 | end-struct multiboot-info% 64 | 65 | \ The module structure 66 | struct 67 | 32bits field module-mod-start 68 | 32bits field module-mod-end 69 | 32bits field module-mod-string 70 | 32bits field module-mod-reserved 71 | end-struct module% 72 | 73 | \ The memory map. Be careful that the offset 0 is base_addr_low but no size. 74 | struct 75 | 32bits field memory-map-size 76 | 32bits field memory-map-base-addr-low 77 | 32bits field memory-map-base-addr-high 78 | 32bits field memory-map-length-low 79 | 32bits field memory-map-length-high 80 | 32bits field memory-map-type 81 | end-struct memory-map% 82 | 83 | multiboot_addr @ feature __MULTIBOOT__ 84 | 85 | [ifdef] __MULTIBOOT__ 86 | multiboot_addr @ constant mb-> 87 | mb-> multiboot-info-flags @ constant flags 88 | flags 1 bit? feature __MULTIBOOT_MEM__ 89 | [endif] 90 | 91 | : kb 1024 * ; 92 | : mb 1024 kb * ; 93 | 94 | [ifdef] __MULTIBOOT_MEM__ 95 | mb-> multiboot-info-mem-upper @ kb constant mem-upper-size 96 | mem-upper-size 1 MB + constant mem-upper-limit 97 | [else] 98 | $ffffffff constant mem-upper-limit 99 | [endif] 100 | 101 | 102 | \ multiboot.fs ends here 103 | -------------------------------------------------------------------------------- /kernel/serial.fs: -------------------------------------------------------------------------------- 1 | \ serial.fs -- Serial port communication 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | vocabulary serial 21 | also serial definitions 22 | 23 | variable serial-echo 24 | 25 | : serial-echo-on true serial-echo ! ; 26 | : serial-echo-off false serial-echo ! ; 27 | 28 | serial-echo-off 29 | 30 | $3f8 constant com1 31 | 32 | $00 com1 1 + outputb \ Disable all interrupts 33 | $80 com1 3 + outputb \ Enable DLAB (set baud rate divisor) 34 | $03 com1 0 + outputb \ Set divisor to 3 (lo byte) 38400 baud 35 | $00 com1 1 + outputb \ (hi byte) 36 | $03 com1 3 + outputb \ 8 bits, no parity, one stop bit 37 | $c7 com1 2 + outputb \ Enable FIFO, clear them, with 14-byte threshold 38 | $0b com1 4 + outputb \ IRQs enabled, RTS/DSR set 39 | 40 | : empty? com1 5 + inputb 32 and ; 41 | 42 | : write-byte ( x -- ) 43 | begin empty? until 44 | com1 outputb 45 | ; 46 | 47 | : received? 48 | com1 5 + inputb 1 and ; 49 | 50 | : read-byte ( -- x ) 51 | begin received? until 52 | com1 inputb 53 | dup emit 54 | serial-echo @ if 55 | dup 13 = if 56 | 10 write-byte 57 | else 58 | dup write-byte 59 | then 60 | then 61 | ; 62 | 63 | previous definitions 64 | 65 | \ serial.fs ends here 66 | -------------------------------------------------------------------------------- /kernel/speaker.fs: -------------------------------------------------------------------------------- 1 | \ speaker.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @kernel/timer.fs 21 | 22 | : sound ( freq - ) 23 | 1193180 swap / 24 | $b6 $43 outputb 25 | dup low-byte $42 outputb 26 | high-byte $42 outputb 27 | $61 inputb 28 | dup dup 3 or <> if 29 | 3 or $61 outputb 30 | then ; 31 | 32 | : nosound 33 | $61 inputb 34 | $fc and 35 | $61 outputb ; 36 | 37 | : play ( freq ms ) 38 | swap sound ms nosound ; 39 | 40 | : beep 1000 150 play ; 41 | 42 | 43 | vocabulary music 44 | also music definitions 45 | 46 | : note 47 | [compile] : 48 | [compile] literal 49 | 300 50 | [compile] literal 51 | postpone play 52 | 15 53 | [compile] literal 54 | postpone ms 55 | [compile] ; 56 | ; 57 | 58 | 16 note 0c 33 note 1c 65 note 2c 131 note 3c 59 | 17 note 0c# 35 note 1c# 69 note 2c# 139 note 3c# 60 | 18 note 0d 37 note 1d 73 note 2d 147 note 3d 61 | 19 note 0d# 39 note 1d# 78 note 2d# 155 note 3d# 62 | 21 note 0e 41 note 1e 82 note 2e 165 note 3e 63 | 22 note 0f 44 note 1f 87 note 2f 175 note 3f 64 | 23 note 0f# 46 note 1f# 92 note 2f# 185 note 3f# 65 | 24 note 0g 49 note 1g 98 note 2g 196 note 3g 66 | 26 note 0g# 52 note 1g# 104 note 2g# 208 note 3g# 67 | 27 note 0a 55 note 1a 110 note 2a 220 note 3a 68 | 29 note 0a# 58 note 1a# 116 note 2a# 233 note 3a# 69 | 31 note 0b 62 note 1b 123 note 2b 245 note 3b 70 | 71 | 262 note 4c 523 note 5c 1046 note 6c 2093 note 7c 72 | 277 note 4c# 554 note 5c# 1109 note 6c# 2217 note 7c# 73 | 294 note 4d 587 note 5d 1175 note 6d 2349 note 7d 74 | 311 note 4d# 622 note 5d# 1244 note 6d# 2489 note 7d# 75 | 330 note 4e 659 note 5e 1328 note 6e 2637 note 7e 76 | 349 note 4f 698 note 5f 1397 note 6f 2794 note 7f 77 | 370 note 4f# 740 note 5f# 1480 note 6f# 2960 note 7f# 78 | 392 note 4g 784 note 5g 1568 note 6g 3136 note 7g 79 | 415 note 4g# 831 note 5g# 1661 note 6g# 3322 note 7g# 80 | 440 note 4a 880 note 5a 1760 note 6a 3520 note 7a 81 | 466 note 4a# 932 note 5a# 1865 note 6a# 3729 note 7a# 82 | 494 note 4b 988 note 5b 1975 note 6b 3951 note 7b 83 | 84 | ' 4c alias -c ' 5c alias c ' 6c alias +c 85 | ' 4c# alias -c# ' 5c# alias c# ' 6c# alias +c# 86 | ' 4d alias -d ' 5d alias d ' 6d alias +d 87 | ' 4d# alias -d# ' 5d# alias d# ' 6d# alias +d# 88 | ' 4e alias -e ' 5e alias e ' 6e alias +e 89 | ' 4f alias -f ' 5f alias f ' 6f alias +f 90 | ' 4f# alias -f# ' 5f# alias f# ' 6f# alias +f# 91 | ' 4g alias -g ' 5g alias g ' 6g alias +g 92 | ' 4g# alias -g# ' 5g# alias g# ' 6g# alias +g# 93 | ' 4a alias -a ' 5a alias a ' 6a alias +a 94 | ' 4a# alias -a# ' 5a# alias a# ' 6a# alias +a# 95 | ' 4b alias -b ' 5b alias b ' 6b alias +b 96 | 97 | PREVIOUS DEFINITIONS 98 | 99 | : previous ; immediate 101 | 102 | : birthday 103 | 109 | ; 110 | -------------------------------------------------------------------------------- /kernel/timer.fs: -------------------------------------------------------------------------------- 1 | \ timer.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @structures.fs 21 | require @kernel/irq.fs 22 | 23 | \ Yes, I know this could be more accurate. But I don't need 24 | \ currently. If you feel that it is important, write it, please! 25 | 26 | 1193182 constant clock-tick-rate 27 | 1000 constant hz 28 | clock-tick-rate hz / constant latch 29 | 30 | $40 constant pit-channel0 31 | : set-channel0-reload ( n -- ) 32 | dup low-byte pit-channel0 outputb 33 | high-byte pit-channel0 outputb ; 34 | 35 | \ Setup the PIT frequency to 1000 Hz (roughly) 36 | latch set-channel0-reload 37 | 38 | struct 39 | cell field timer-routine 40 | cell field timer-reset 41 | cell field timer-countdown 42 | end-struct timer% 43 | 44 | create TIMER0 timer% zallot 45 | create TIMER1 timer% zallot 46 | create TIMER2 timer% zallot 47 | create TIMER3 timer% zallot 48 | 49 | : reset-timer ( timer -- ) 50 | dup timer-reset @ swap timer-countdown ! ; 51 | 52 | : set-timer ( miliseconds xt timer -- ) 53 | tuck timer-routine ! timer-reset ! ; 54 | 55 | \ Implementation 56 | 57 | : process-timer-tick ( timer -- ) 58 | dup timer-countdown @ 0= if drop exit then 59 | dup timer-countdown 1-! 60 | dup timer-countdown @ 0= if timer-routine @ execute else drop then ; 61 | 62 | 63 | variable internal-run-time 64 | variable countdown 65 | 66 | : irq-timer ( isrinfo ) drop 67 | internal-run-time 1+! 68 | countdown @ dup if 1- countdown ! else drop then 69 | TIMER0 process-timer-tick 70 | TIMER1 process-timer-tick 71 | TIMER2 process-timer-tick 72 | TIMER3 process-timer-tick 73 | ; 0 IRQ 74 | 75 | : set-countdown countdown ! ; 76 | : wait-for-countdown begin countdown @ while halt repeat ; 77 | 78 | : get-internal-run-time internal-run-time @ ; 79 | 80 | : time get-internal-run-time ; 81 | 82 | \ Wait for (rougly) N milliseconds. 83 | : ms ( n -- ) 84 | set-countdown wait-for-countdown ; 85 | 86 | \ timer.fs ends here 87 | -------------------------------------------------------------------------------- /kernel/video.fs: -------------------------------------------------------------------------------- 1 | \ Video subsystem 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ Video 21 | 22 | $b8000 constant video-addr 23 | 24 | 80 constant video-width 25 | 25 constant video-height 26 | 27 | : video-memsize 28 | video-width video-height * 2* ; 29 | 30 | : offset>cords ( offset -- row col ) 31 | video-width /mod swap ; 32 | 33 | : cords>offset ( row col -- offset ) 34 | swap video-width * + ; 35 | 36 | : v-offset ( row col -- offset ) 37 | cords>offset 2* video-addr + ; 38 | 39 | : v-glyph@ ( row col -- ch ) 40 | v-offset c@ ; 41 | 42 | : v-glyph! ( ch row col -- ) 43 | v-offset c! ; 44 | 45 | : v-attr@ ( row col -- attr ) 46 | v-offset 1+ c@ ; 47 | 48 | : v-attr! ( attr row col -- ) 49 | v-offset 1+ c! ; 50 | 51 | \ CRTC 52 | 53 | $3D4 constant crtc-index 54 | $3D5 constant crtc-data 55 | 56 | : crtc! ( value reg -- ) 57 | crtc-index outputb 58 | crtc-data outputb ; 59 | 60 | 61 | \ Cursor hardware 62 | 63 | $0E constant crtc-index-location-high 64 | $0F constant crtc-index-location-low 65 | 66 | : low-byte $ff and ; 67 | 68 | : high-and-low-bytes ( x -- high low ) 69 | dup 8 rshift low-byte 70 | swap low-byte ; 71 | 72 | : v-cursor-set-offset ( offset -- ) 73 | high-and-low-bytes 74 | crtc-index-location-low crtc! 75 | crtc-index-location-high crtc! ; 76 | 77 | : v-cursor-set-position ( row col -- ) 78 | cords>offset v-cursor-set-offset ; 79 | 80 | 81 | \ video.fs ends here 82 | -------------------------------------------------------------------------------- /linedit.fs: -------------------------------------------------------------------------------- 1 | \ linedit.fs -- Text line editor 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | \ TODO: Do it extensible! 21 | 22 | require @string.fs 23 | require @kernel/console.fs 24 | require @kernel/keyboard.fs 25 | 26 | true value visible-bell 27 | 28 | \ Include a newline feedkback in the screen? 29 | variable end-newline-p 30 | 31 | variable buffer 32 | variable buffer-size 33 | variable gap-start 34 | variable gap-end 35 | 36 | variable finishp 37 | 38 | : flash invert-screen 50 ms invert-screen ; 39 | : alert visible-bell if flash else beep endif ; 40 | 41 | : point gap-start @ ; 42 | 43 | : char-at ( n -- ) buffer @ + c@ ; 44 | : at-beginning? gap-start @ 0= ; 45 | : at-end? gap-end @ buffer-size @ = ; 46 | : full? gap-start @ gap-end @ = ; 47 | 48 | : previous-char gap-start @ 1- char-at ; 49 | : next-char gap-end @ char-at ; 50 | 51 | : before-space? at-end? not next-char 32 = and ; 52 | : after-space? at-beginning? not previous-char 32 = and ; 53 | 54 | : before-nonspace? at-end? not next-char 32 <> and ; 55 | : after-nonspace? at-beginning? not previous-char 32 <> and ; 56 | 57 | : at-end-word? 58 | after-nonspace? 59 | before-space? at-end? or 60 | and ; 61 | 62 | \ Internal words 63 | 64 | variable screen-x 65 | variable screen-y 66 | 67 | : remember-location 68 | cursor-x @ screen-x ! 69 | cursor-y @ screen-y ! ; 70 | 71 | : restore-location 72 | screen-x @ cursor-x ! 73 | screen-y @ cursor-y ! ; 74 | 75 | : setup-gap-buffer 76 | dup buffer-size ! 77 | ( ) gap-end ! 78 | buffer ! 79 | gap-start 0! ; 80 | 81 | : clear-current-line 82 | video-width screen-x @ ?do 83 | screen-y @ i clear-char 84 | loop ; 85 | 86 | 87 | \ Editing commands 88 | 89 | : le-insert ( ch -- ) 90 | full? if 91 | drop alert 92 | else 93 | ( ch ) gap-start @ buffer @ + c! 94 | gap-start 1+! 95 | endif 96 | ; 97 | 98 | : le-delete-char 99 | at-end? if alert else gap-end 1+! endif ; 100 | 101 | : le-delete-backward-char 102 | at-beginning? if alert else gap-start 1-! endif ; 103 | 104 | : le-forward-char 105 | at-end? if 106 | alert 107 | else 108 | gap-end @ buffer @ + c@ 109 | gap-start @ buffer @ + c! 110 | gap-start 1+! 111 | gap-end 1+! 112 | endif 113 | ; 114 | 115 | : le-backward-char 116 | at-beginning? if 117 | alert 118 | else 119 | gap-start 1-! 120 | gap-end 1-! 121 | buffer @ gap-start @ + c@ 122 | buffer @ gap-end @ + c! 123 | endif 124 | ; 125 | 126 | : le-forward-word 127 | begin before-space? while le-forward-char repeat 128 | begin before-nonspace? while le-forward-char repeat ; 129 | 130 | : le-backward-word 131 | begin after-space? while le-backward-char repeat 132 | begin after-nonspace? while le-backward-char repeat ; 133 | 134 | : le-delete-word 135 | begin before-space? while le-delete-char repeat 136 | begin before-nonspace? while le-delete-char repeat ; 137 | 138 | : le-delete-backward-word 139 | begin after-space? while le-delete-backward-char repeat 140 | begin after-nonspace? while le-delete-backward-char repeat ; 141 | 142 | : le-move-beginning-of-line 143 | begin at-beginning? not while le-backward-char repeat ; 144 | 145 | : le-move-end-of-line 146 | begin at-end? not while le-forward-char repeat ; 147 | 148 | : le-kill-line 149 | buffer-size @ gap-end ! ; 150 | 151 | : le-return 152 | at-end? if finishp on else le-move-end-of-line endif ; 153 | 154 | : le-clear 155 | 0 0 at-xy 156 | remember-location 157 | page ; 158 | 159 | 160 | \ Autocompletion 161 | 162 | \ First of all, we provide two useful twords, INITIALIZE-CORDER and 163 | \ NEXT-WORD, which the iteration across the avalaible words relies on. 164 | \ So, the completion code accesss to the words in a linear and easy 165 | \ way. Then, implement autocompletion is as simple as record some 166 | \ screen settings and filter the words. 167 | 168 | \ This array contains a parallel search order. 169 | create corder-stack sorder_size cells allot 170 | variable corder-tos 171 | variable corder-nt 172 | 173 | \ Copy the search order stack to the completion order stack. 174 | : initialize-corder-nt 175 | context @ wid>latest corder-nt ! ; 176 | : initialize-corder-tos 177 | sorder_tos @ corder-tos ! ; 178 | : initialize-corder-stack 179 | get-order 0 ?do corder-stack i cells + ! loop ; 180 | 181 | \ Push the address of the completion order. 182 | : ccontext ( -- wid ) 183 | corder-tos @ cells corder-stack + ; 184 | 185 | : next-ccontext ( -- flag ) 186 | corder-tos @ 0 > if 187 | corder-tos 1-! 188 | ccontext @ wid>latest corder-nt ! 189 | true 190 | else 191 | false 192 | endif 193 | ; 194 | 195 | \ INITIALIZE-CORDER inits the completion search. It must be called 196 | \ before NEXT-WORD. After that, every call to NEXT-WORD will return 197 | \ the next word avalaible and so, until it returns 0, which indicates 198 | \ that there is not more accessible words. 199 | 200 | : initialize-corder ( -- ) 201 | initialize-corder-nt 202 | initialize-corder-tos 203 | initialize-corder-stack ; 204 | 205 | : next-word ( -- nt|0 ) 206 | corder-nt @ ?dup if 207 | dup previous-word corder-nt ! 208 | else 209 | next-ccontext if recurse else 0 endif 210 | endif ; 211 | 212 | 213 | \ PREFIX-ADDR and PREFIX-SIZE variables contain the address of the 214 | \ string to be completed and the size respectively. 215 | variable prefix-addr 216 | variable prefix-size 217 | \ Size of the extra size in a completion 218 | variable subfix-size 219 | \ It is TRUE if we are completing a word and it is not the first 220 | \ one. So, if other completion arises, it will share the same prefix. 221 | variable completing? 222 | 223 | : setup-prefix ( addr n -- ) 224 | prefix-size ! prefix-addr ! ; 225 | 226 | : prefix prefix-addr @ prefix-size @ ; 227 | 228 | : word-at-point ( -- addr n ) 229 | \ Note: we are assuming that the AT-END-WORD? is true. 230 | le-backward-word 231 | point buffer @ + 232 | le-forward-word 233 | point buffer @ + 234 | over - ; 235 | 236 | : next-match ( -- addr n ) 237 | begin 238 | next-word dup while 239 | \ ." Trying: " dup id. cr 240 | dup nt>name prefix string-prefix? if 241 | nt>name 242 | exit 243 | else 244 | drop 245 | endif 246 | repeat 247 | ; 248 | 249 | \ Delete the added characteres by the last completion. 250 | : delete-subfix 251 | subfix-size @ 0 ?do le-delete-backward-char loop ; 252 | 253 | \ Skip the prefixed characters of a completion. 254 | : skip-prefix ( addr n -- addr+PREFIX-SIZE n-PREFIX-SIZE ) 255 | prefix-size @ - swap 256 | prefix-size @ + swap ; 257 | 258 | : insert-string ( addr n -- ) 259 | 0 ?do dup c@ le-insert 1+ loop drop ; 260 | 261 | : complete-word 262 | delete-subfix 263 | next-match ?dup if 264 | skip-prefix dup subfix-size ! 265 | insert-string 266 | else 267 | completing? off 268 | endif 269 | ; 270 | 271 | : le-complete-word 272 | at-end-word? if 273 | completing? @ not if 274 | initialize-corder 275 | word-at-point setup-prefix 276 | subfix-size 0! 277 | completing? on 278 | endif 279 | complete-word 280 | endif 281 | ; 282 | 283 | 284 | \ Initialization and finalization 285 | 286 | : init ( buffer size -- ) 287 | false finishp ! 288 | remember-location 289 | setup-gap-buffer ; 290 | 291 | : finalize ( -- c) 292 | le-move-end-of-line 293 | gap-start @ ; 294 | 295 | 296 | \ Rendering 297 | 298 | : render-pre-cursor 299 | gap-start @ 0 ?do 300 | buffer @ i + @ emit-char 301 | loop ; 302 | 303 | : render-post-cursor 304 | buffer-size @ gap-end @ ?do 305 | buffer @ i + @ emit-char 306 | loop ; 307 | 308 | : render ( -- ) 309 | clear-current-line 310 | restore-location 311 | render-pre-cursor 312 | update-hardware-cursor 313 | render-post-cursor ; 314 | 315 | \ Looping 316 | 317 | : non-special-key? $80 <= ; 318 | 319 | : alt-dispatcher 320 | case 321 | [char] f of le-forward-word endof 322 | [char] b of le-backward-word endof 323 | [char] d of le-delete-word endof 324 | BACK of le-delete-backward-word endof 325 | endcase 326 | ; 327 | : ctrl-dispatcher 328 | case 329 | [char] a of le-move-beginning-of-line endof 330 | [char] e of le-move-end-of-line endof 331 | [char] f of le-forward-char endof 332 | [char] b of le-backward-char endof 333 | [char] d of le-delete-char endof 334 | [char] k of le-kill-line endof 335 | [char] l of le-clear endof 336 | endcase 337 | ; 338 | : command-dispatcher ( key modifiers -- ) 339 | over TAB = if 340 | 2drop le-complete-word 341 | exit 342 | else 343 | completing? off 344 | endif 345 | dup alt-mod = if 346 | drop 347 | alt-dispatcher 348 | exit 349 | endif 350 | dup ctrl-mod = if 351 | drop 352 | ctrl-dispatcher 353 | exit 354 | endif 355 | dup ctrl-mod alt-mod or = if 356 | 2drop 357 | exit 358 | endif 359 | over RET = if 360 | 2drop 361 | le-return 362 | exit 363 | endif 364 | over non-special-key? if 365 | drop le-insert 366 | exit 367 | endif 368 | over BACK = if 369 | 2drop le-delete-backward-char 370 | exit 371 | endif 372 | over LEFT = if 373 | 2drop le-backward-char 374 | exit 375 | endif 376 | over RIGHT = if 377 | 2drop le-forward-char 378 | exit 379 | endif 380 | 2drop 381 | ; 382 | 383 | : looping ( -- ) 384 | begin 385 | render 386 | ekey 387 | command-dispatcher 388 | finishp @ until ; 389 | 390 | 391 | \ High level words 392 | 393 | : edit-line ( addr n1 n2 -- n3 ) 394 | >r init r> gap-start ! 395 | looping 396 | finalize 397 | end-newline-p @ if cr endif ; 398 | 399 | : accept ( addr n1 -- n2 ) 400 | 0 edit-line ; 401 | 402 | \ linedit.fs ends here 403 | -------------------------------------------------------------------------------- /lisp/core.lisp: -------------------------------------------------------------------------------- 1 | ;;; (defmacro name args body) 2 | ;;; => 3 | ;;; (fset name `(macro lambda ,args ,body)) 4 | (fset 'defmacro 5 | '(macro lambda (name args expr) 6 | (list 'fset (list 'quote name) 7 | (list 'quote 8 | (list 'macro 'lambda args expr))))) 9 | 10 | (defmacro setq (symbol value) 11 | (list 'set (list 'quote symbol) value)) 12 | 13 | (defmacro si (condition true false) 14 | (list 'if condition true false)) 15 | 16 | (defmacro lambda (args body) 17 | (list 'quote (list 'lambda args body))) 18 | 19 | (defmacro defun (name args body) 20 | (list 'progn 21 | (list 'fset (list 'quote name) 22 | (list 'quote (list 'lambda args body))) 23 | (list 'quote name))) 24 | 25 | (defmacro defvar (name value) 26 | (list 'setq name value)) 27 | 28 | (defun atom (x) 29 | (not (consp x))) 30 | 31 | (defun mapcar (f list) 32 | (if (null list) 33 | nil 34 | (cons (funcall f (car list)) 35 | (mapcar f (cdr list))))) 36 | 37 | (defun cadr (x) 38 | (car (cdr x))) 39 | 40 | (defun %let-binding-name (binding) 41 | (if (consp binding) 42 | (car binding) 43 | binding)) 44 | (defun %let-binding-value (binding) 45 | (if (consp binding) 46 | (cadr binding) 47 | nil)) 48 | 49 | (defmacro let (bindings expr) 50 | (list '%let 51 | (mapcar '%let-binding-name bindings) 52 | (mapcar '%let-binding-value bindings) 53 | expr)) 54 | 55 | (defun %time-call (function) 56 | (let ((before (get-internal-run-time)) 57 | after 58 | value) 59 | (progn 60 | (setq value (funcall function)) 61 | (setq after (get-internal-run-time)) 62 | (print 'MILISECONDS=) 63 | (print (- after before)) 64 | (terpri) 65 | value))) 66 | 67 | (defmacro time (expr) 68 | (list '%time-call (list 'lambda () expr))) 69 | -------------------------------------------------------------------------------- /lisp/lisp.fs: -------------------------------------------------------------------------------- 1 | \ lisp.fs --- A straighforward dynamically-scoped Lisp interpreter 2 | 3 | \ Copyright 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | vocabulary lisp 21 | get-current 22 | also eulex 23 | also lisp definitions 24 | 25 | \ : DEBUG ; 26 | 27 | ' postpone alias `` immediate 28 | ' compile-only alias c/o 29 | : imm-c/o immediate compile-only ; 30 | 31 | 3 constant tag-bits 32 | 1 tag-bits lshift 1 - constant tag-mask 33 | 34 | %000 constant even-fixnum-tag 35 | %001 constant cons-tag 36 | %010 constant symbol-tag 37 | %011 constant subr-tag 38 | %100 constant odd-fixnum-tag 39 | \ %101 constant reserved 40 | \ %110 constant reserved 41 | %111 constant forward-tag 42 | 43 | : tag tag-mask and ; 44 | : tagged or ; 45 | : ?tagged swap dup 0= if nip else swap tagged then ; 46 | : untag tag-mask invert and ; 47 | 48 | \ Memory management and garbage collection 49 | \ ( Cheney's algorithm ) 50 | 51 | \ A stack of pinned objects. Use it to protect shadown symbol values 52 | \ and other Lisp objects which could not to be accesible from Lisp 53 | \ temporarly. 54 | 4096 constant pinned-size 55 | create pinned pinned-size zallot 56 | variable pinned-count 57 | 58 | : >p 59 | pinned-count @ pinned-size = if abort" Too depth recursion." endif 60 | pinned pinned-count @ cells + ! pinned-count 1+! ; 61 | : pdrop pinned-count 1-! ; 62 | 63 | : pinargs ( arg1 ... argn n -- arg1 ... argn n ) 64 | dup 0 ?do i 1+ pick >p loop ; 65 | 66 | : unpinargs ( n -- ) 67 | 0 ?do pdrop loop ; 68 | 69 | 65536 constant dynamic-space 70 | 71 | : initvar variable latestxt execute ! ; 72 | 73 | \ From space 74 | dynamic-space allocate throw initvar fromsp-base 75 | fromsp-base @ dynamic-space + initvar fromsp-limit 76 | \ To space 77 | dynamic-space allocate throw initvar tosp-base 78 | tosp-base @ dynamic-space + initvar tosp-limit 79 | 80 | variable &alloc 81 | variable &scan 82 | 83 | \ These functions receive a Lisp object and return a reference to the 84 | \ new object in the to space. It allocates the object if it is 85 | \ required, marking it with a forward pointer. 86 | create copy-functions 1 tag-bits lshift cells zallot 87 | 88 | : copy-method! ( xt tag -- ) 89 | cells copy-functions + ! ; 90 | : copy-method ( obj -- xt ) 91 | tag cells copy-functions + @ ; 92 | 93 | : swap-cells ( addr1 addr2 -- ) 94 | dup @ -rot >r dup @ r> ! ! ; 95 | 96 | : swap-spaces 97 | fromsp-base tosp-base swap-cells 98 | fromsp-limit tosp-limit swap-cells 99 | tosp-base @ dup &alloc ! &scan ! ; latestxt execute 100 | 101 | : >tosp ( addr n -- addr* ) 102 | tuck &alloc @ swap move 103 | &alloc @ swap &alloc +! ; 104 | 105 | : forward-reference ( old -- new|0 ) 106 | dup tag swap untag @ ( tag cell ) 107 | dup tag forward-tag = if untag tagged else 2drop 0 endif ; 108 | 109 | : markgc! ( old new -- ) 110 | untag forward-tag tagged swap untag ! ; 111 | 112 | : valid-obj? ( obj -- ) 113 | fromsp-base @ swap untag fromsp-limit @ between ; 114 | 115 | : copy ( x -- x* ) 116 | dup copy-method over valid-obj? and if 117 | dup forward-reference ?dup if 118 | else 119 | dup dup copy-method execute tuck markgc! 120 | endif 121 | endif ; 122 | 123 | defer copy-root-symbols 124 | 125 | : copy-pinned 126 | pinned-count @ 0 ?do 127 | pinned i cells + 128 | dup @ copy swap ! 129 | loop ; 130 | 131 | : gc 132 | [IFDEF] DEBUG CR ." Garbage collecting..." [ENDIF] 133 | swap-spaces 134 | copy-root-symbols copy-pinned 135 | begin 136 | &scan @ &alloc @ u< while 137 | &scan @ dup @ copy swap ! 138 | &scan @ cell+ &scan ! 139 | repeat ; 140 | 141 | : alloc-obj ( n -- obj f ) 142 | dup &alloc @ + tosp-limit @ >= if gc endif 143 | dup &alloc @ + tosp-limit @ >= if abort" Out of memory" endif 144 | &alloc @ swap &alloc +! 0 ; 145 | 146 | [IFDEF] DEBUG 147 | : .debug 148 | CR 149 | ." From space: " 150 | fromsp-base @ dynamic-space dump CR 151 | ." ALLOC = " &alloc @ print-hex-number CR 152 | ." SCAN = " &scan @ print-hex-number CR 153 | ." To space: " 154 | tosp-base @ dynamic-space dump CR ; 155 | [ENDIF] 156 | 157 | 158 | 159 | \ Errors 160 | : void-variable 1 throw ; 161 | : void-function 2 throw ; 162 | : wrong-type-argument 3 throw ; 163 | : wrong-number-of-arguments 4 throw ; 164 | : parse-error 5 throw ; 165 | : quit-condition 6 throw ; 166 | : eof-condition 7 throw ; 167 | 168 | \ Defered words 169 | defer eval-lisp-obj 170 | defer read-lisp-obj 171 | 172 | \ Symbols 173 | 174 | \ We write the lisp package system upon wordlists. The PF of the words 175 | \ contains the symbol value and the symbol function parameters aligned 176 | \ to a double cell size. 177 | wordlist constant lisp-package 178 | 179 | : in-lisp-package: 180 | lisp-package 1 set-order ; 181 | 182 | : create-in-lisp-package 183 | get-order get-current in-lisp-package: definitions 184 | create set-current set-order ; 185 | 186 | : find-cname-in-lisp-package ( c-addr -- nt|0 ) 187 | >r get-order in-lisp-package: r> 188 | find-cname >r set-order r> ; 189 | 190 | : create-symbol 191 | create-in-lisp-package latest 2align , does> 2aligned symbol-tag tagged ; 192 | 193 | : ::unbound 194 | [ here 2aligned symbol-tag tagged ]L ; 195 | 196 | : declare-symbol 197 | create-symbol ::unbound , ::unbound , ; 198 | 199 | create-symbol t latestxt execute , ::unbound , 200 | create-symbol nil latestxt execute , ::unbound , 201 | 202 | declare-symbol quote 203 | declare-symbol progn 204 | declare-symbol lambda 205 | declare-symbol macro 206 | declare-symbol if 207 | declare-symbol backquote 208 | declare-symbol comma 209 | 210 | : find-symbol ( c-addr -- symbol|0 ) 211 | find-cname-in-lisp-package dup if nt>xt execute endif ; 212 | 213 | : intern-symbol ( c-addr -- symbol ) 214 | dup find-symbol ?dup if nip else 215 | count nextname create-symbol ::unbound , ::unbound , 216 | latestxt execute 217 | then ; 218 | 219 | : '' parse-cname find-symbol ; 220 | : [''] '' `` literal ; immediate 221 | 222 | \ #DOSYMBOLS...#ENDSYMBOLS 223 | \ 224 | \ Iterate across the symbols in the package. The body is executed with 225 | \ a symbol in the TOS each time. The body must drop the symbol from 226 | \ the stack. 227 | : #dosymbols 228 | `` lisp-package 229 | `` DOWORDS 230 | `` dup `` >r 231 | `` nt>xt `` execute 232 | ; imm-c/o 233 | 234 | : #endsymbols 235 | `` r> 236 | `` ENDWORDS 237 | ; imm-c/o 238 | 239 | '' t constant t 240 | '' nil constant nil 241 | 242 | : >bool if t else nil then ; 243 | : bool> nil = if 0 else -1 then ; 244 | 245 | : #symbolp tag symbol-tag = >bool ; 246 | 247 | \ Check if X is a symbol object. If not, it signals an error. 248 | : check-symbol ( x -- x ) 249 | dup #symbolp nil = if wrong-type-argument then ; 250 | 251 | : symbol-name ( symbol -- caddr ) 252 | check-symbol untag @ ; 253 | 254 | : safe-symbol-value check-symbol untag cell+ @ ; 255 | : safe-symbol-function check-symbol untag 2 cells + @ ; 256 | 257 | : #symbol-value ( symbol -- value ) 258 | safe-symbol-value dup ::unbound = if void-variable endif ; 259 | 260 | : #symbol-function ( symbol -- value ) 261 | safe-symbol-function dup ::unbound = if void-function endif ; 262 | 263 | \ Don't forget that #SET and #FSET words return the newly assigned 264 | \ value, so if you are not going to use that value, drop it. 265 | : #set ( symb value -- value ) 266 | tuck swap check-symbol untag cell+ ! ; 267 | 268 | : #fset ( symbol definition -- definition ) 269 | tuck swap check-symbol untag 2 cells + ! ; 270 | 271 | :noname 272 | #dosymbols 273 | dup 274 | dup safe-symbol-value copy #set drop 275 | dup safe-symbol-function copy #fset drop 276 | #endsymbols 277 | ; is copy-root-symbols 278 | 279 | 280 | \ Lisp basic conditional. It runs the true-branch if the top of the 281 | \ stack is non-nil. It is compatible with `else' and `then' words. 282 | : nil/= nil = not ; 283 | : #if `` nil/= `` if ; imm-c/o 284 | : #while `` nil/= `` while ; imm-c/o 285 | : #until `` nil/= `` until ; imm-c/o 286 | 287 | 288 | \ CONSes 289 | 290 | variable allocated-conses 291 | 292 | :noname 293 | untag 2 cells >tosp cons-tag tagged 294 | ; cons-tag copy-method! 295 | 296 | : #cons ( x y -- cons ) 297 | 2 cells alloc-obj throw 298 | tuck cell+ ! tuck ! cons-tag tagged 299 | allocated-conses 1+! ; 300 | 301 | : #consp tag cons-tag = >bool ; 302 | 303 | : check-cons 304 | dup #consp nil = if wrong-type-argument endif ; 305 | 306 | : #car dup #if check-cons untag @ endif ; 307 | : #cdr dup #if check-cons untag cell + @ endif ; 308 | 309 | \ Return the cdr of a cons. If the result is NIL, signals an error. 310 | : assert-cdr 311 | #cdr dup nil = if parse-error endif ; 312 | 313 | : #dolist 314 | `` begin 315 | `` dup `` #while 316 | `` dup `` >r 317 | `` #car 318 | ; imm-c/o 319 | : #repeat 320 | `` r> 321 | `` #cdr 322 | `` repeat 323 | `` drop 324 | ; imm-c/o 325 | 326 | 327 | \ SUBRS (primitive functions) 328 | 329 | : special-subr? untag @ 0= ; 330 | : subr>xt cell+ ; 331 | 332 | -1 constant infinite 333 | 334 | : unlist ( list -- arg1 arg2 .. argn n ) 335 | 0 swap #dolist swap 1+ #repeat ; 336 | 337 | : check-number-of-arguments ( n min max ) 338 | >r over r> between if else wrong-number-of-arguments endif ; 339 | 340 | ' unlist alias non-eval-args 341 | 342 | : eval-and-unlist ( list -- ) 343 | 0 swap #dolist eval-lisp-obj swap 1+ #repeat ; 344 | 345 | : eval-funcall-args 346 | eval-and-unlist ; 347 | 348 | \ Create a subr object (a primitive function to the Lisp system), 349 | \ which accepts between MIN and MAX arguments, checks that the number 350 | \ of arguments is correct and then call to the execution token XT. 351 | : create-subr ( min max evaluated xt -- subr ) 352 | 2align here >r 353 | swap , 354 | -rot swap 2dup `` literal `` literal `` check-number-of-arguments 355 | ( min max ) = if `` drop endif 356 | `` literal `` execute 357 | return 358 | r> subr-tag tagged ; 359 | 360 | : register-subr ( min max evaluated xt parse:name -- ) 361 | create-subr parse-cname intern-symbol swap #fset drop ; 362 | 363 | 2 2 true ' #cons register-subr cons 364 | 1 1 true ' #consp register-subr consp 365 | 1 1 true ' #car register-subr car 366 | 1 1 true ' #cdr register-subr cdr 367 | 1 1 true ' #symbolp register-subr symbolp 368 | 1 1 true ' #symbol-value register-subr symbol-value 369 | 1 1 true ' #symbol-function register-subr symbol-function 370 | 2 2 true ' #set register-subr set 371 | 2 2 true ' #fset register-subr fset 372 | 373 | : exactly dup ; 374 | : or-more infinite ; 375 | : noargs 0 exactly ; 376 | : unary 1 exactly ; 377 | : binary 2 exactly ; 378 | : function: true latestxt register-subr ; 379 | 380 | : #subrp tag subr-tag = >bool ; 381 | unary function: subrp 382 | 383 | : execute-subr ( arg1 arg2 .. argn n subr -- ... ) 384 | untag subr>xt execute ; 385 | 386 | : #eq = >bool ; 387 | binary function: eq 388 | 389 | : #functionp ( x -- bool ) 390 | dup #symbolp #if safe-symbol-function endif 391 | dup #subrp #if 392 | special-subr? not >bool 393 | else 394 | dup #consp #if 395 | #car [''] lambda #eq 396 | else 397 | nil 398 | endif 399 | endif ; 400 | unary function: functionp 401 | 402 | \ Integers 403 | 404 | : >fixnum 2* 2* ; 405 | : fixnum> 2/ 2/ ; 406 | 407 | : #fixnump 3 and 0= >bool ; unary function: fixnump 408 | ' #fixnump alias #integerp unary function: integerp 409 | 410 | : check-integer ( x -- x ) 411 | dup #integerp nil = if wrong-type-argument endif ; 412 | 413 | : 2-check-integers 414 | check-integer swap check-integer swap ; 415 | 416 | : #= 2-check-integers = >bool ; binary function: = 417 | : #< 2-check-integers < >bool ; binary function: < 418 | : #> 2-check-integers > >bool ; binary function: > 419 | : #<= 2-check-integers <= >bool ; binary function: <= 420 | : #>= 2-check-integers >= >bool ; binary function: >= 421 | : #/= 2-check-integers = not >bool ; binary function: >= 422 | 423 | : #+ 2-check-integers + ; binary function: + 424 | : #- 2-check-integers - ; binary function: - 425 | : #* 2-check-integers fixnum> * ; binary function: * 426 | : #/ 2-check-integers / >fixnum ; binary function: / 427 | 428 | 429 | 430 | : #list ( x1 x2 ... xn n -- list ) 431 | nil swap 0 ?do #cons loop 432 | ; 0 or-more function: list 433 | 434 | : #length ( list -- n ) 435 | 0 swap #dolist drop 1+ #repeat >fixnum ; 436 | unary function: length 437 | 438 | 439 | \ Misc 440 | 441 | : #not #if nil else t endif ; unary function: not 442 | ' #not alias #null unary function: null 443 | 444 | : #get-internal-run-time 445 | get-internal-run-time >fixnum 446 | ; noargs function: get-internal-run-time 447 | 448 | : #terpri cr nil ; noargs function: terpri 449 | 450 | : #quit quit-condition ; 451 | noargs function: quit 452 | 453 | 454 | \ Reader 455 | 456 | : digit-char? ( ch -- bool ) 457 | [char] 0 swap [char] 9 between ; 458 | 459 | : digit-value ( ch -- d ) 460 | [char] 0 - ; 461 | 462 | : whitespace-char? ( ch -- bool ) 463 | case 464 | 32 of true endof 465 | 10 of true endof 466 | 08 of true endof 467 | false swap 468 | endcase ; 469 | 470 | : close-parent? [char] ) = ; 471 | 472 | : discard-char 473 | parse-char drop ; 474 | 475 | : skip-whitespaces 476 | begin peek-char whitespace-char? while discard-char repeat ; 477 | 478 | : peek-conforming-char 479 | skip-whitespaces peek-char ; 480 | 481 | : assert-char 482 | parse-char = invert if parse-error endif ; 483 | 484 | : read-' discard-char [''] quote read-lisp-obj 2 #list ; 485 | : read-` discard-char [''] backquote read-lisp-obj 2 #list ; 486 | : read-, discard-char [''] comma read-lisp-obj 2 #list ; 487 | 488 | : read-(... recursive 489 | peek-conforming-char case 490 | [char] ) of discard-char nil endof 491 | [char] . of 492 | discard-char read-lisp-obj 493 | skip-whitespaces [char] ) assert-char 494 | endof 495 | read-lisp-obj read-(... #cons swap 496 | endcase ; 497 | 498 | : read-( 499 | discard-char peek-conforming-char [char] ) = if discard-char nil else 500 | read-lisp-obj read-(... #cons 501 | endif ; 502 | 503 | : discard-line 504 | begin parse-char 10 = until ; 505 | 506 | : read-; 507 | begin peek-conforming-char [char] ; = while discard-line repeat 508 | read-lisp-obj ; 509 | 510 | 511 | 32 constant token-buffer-size 512 | create token-buffer token-buffer-size allot 513 | 514 | : token-terminal-char? ( ch -- bool ) 515 | dup whitespace-char? swap close-parent? or ; 516 | 517 | : token-size 518 | token-buffer c@ ; 519 | 520 | : full-token-buffer? ( -- bool ) 521 | token-size token-buffer-size >= ; 522 | 523 | : push-token-char ( ch -- ) 524 | full-token-buffer? if drop else 525 | token-buffer 1+ token-size + c! 526 | token-size 1+ token-buffer c! 527 | endif ; 528 | 529 | : read-token 530 | 0 token-buffer c! 531 | begin parse-char push-token-char 532 | peek-char token-terminal-char? until 533 | token-buffer dup c@ 0= if parse-error endif ; 534 | 535 | : try-unumber ( addr u -- d f ) 536 | dup 0= if 2drop 0 0 exit then 537 | 0 -rot 538 | 0 ?do ( d addr ) 539 | dup I + c@ digit-char? if 540 | swap 10 * over I + c@ digit-value + swap 541 | else 542 | unloop drop false exit 543 | endif 544 | loop 545 | drop true ; 546 | 547 | : trim0 ( addr u -- addr+1 u-1 ) 548 | dup if 1- swap 1+ swap endif ; 549 | 550 | : try-number ( addr u -- d f ) 551 | over c@ case 552 | [char] - of trim0 try-unumber swap negate swap endof 553 | [char] + of trim0 try-unumber endof 554 | drop try-unumber 0 555 | endcase ; 556 | 557 | : >sym/num ( c-addr -- x ) 558 | dup count try-number if 559 | nip >fixnum 560 | else 561 | drop intern-symbol 562 | endif ; 563 | 564 | : #read ( -- x ) 565 | peek-conforming-char case 566 | [char] ( of read-( endof 567 | [char] ' of read-' endof 568 | [char] ` of read-` endof 569 | [char] , of read-, endof 570 | [char] ; of read-; endof 571 | [char] . of parse-error endof 572 | 0 of eof-condition endof 573 | drop read-token >sym/num 0 574 | endcase ; 575 | 576 | ' #read is read-lisp-obj 577 | noargs function: read 578 | 579 | 580 | \ Printer 581 | 582 | defer print-lisp-obj 583 | 584 | : print-integer fixnum> print-number ; 585 | : print-symbol symbol-name count type ; 586 | 587 | : print-list 588 | [char] ( emit 589 | dup #car print-lisp-obj #cdr 590 | begin dup #consp #while 591 | space dup #car print-lisp-obj #cdr 592 | repeat 593 | \ Trailing element 594 | dup #if 595 | ." . " print-lisp-obj ." )" 596 | else 597 | drop [char] ) emit 598 | endif ; 599 | 600 | : #print ( x -- x ) 601 | dup 602 | dup #symbolp #if print-symbol exit endif 603 | dup #integerp #if print-integer exit endif 604 | dup #consp #if print-list exit endif 605 | \ Unreadable objects 606 | dup #subrp #if drop ." #" exit endif 607 | drop wrong-type-argument ; 608 | unary function: print 609 | :noname #print drop ; is print-lisp-obj 610 | 611 | 612 | \ Interpreter 613 | 614 | : eval-progn-list ( list -- x ) 615 | nil swap #dolist nip eval-lisp-obj #repeat ; 616 | 617 | \ Funcalls 618 | 619 | : lambda-args assert-cdr #car ; 620 | : lambda-nargs lambda-args #length fixnum> ; 621 | : lambda-body assert-cdr #cdr ; 622 | 623 | \ Swap the values of the cell pointed by ADDR and the value of SYMBOL. 624 | : cell<->symbol ( addr symbol -- ) 625 | dup safe-symbol-value -rot over @ #set drop ! ; 626 | 627 | \ Iterate on the arguments of the lambda, swapping the argument in the 628 | \ stack by the value slot of the symbol. 629 | : stack<->symbols ( a1 a2 ... an n symbs -- v1 v2 ... vn n symbs ) 630 | 2dup 2>r swap 1+ cells sp + swap 631 | #dolist 2dup cell<->symbol drop cell - #repeat 632 | drop 2r> ; 633 | 634 | : eval-with-bindings ( arg1 arg2 ... argn n symbols body -- x ) 635 | >r stack<->symbols >r pinargs r> 636 | r> eval-progn-list 637 | >r stack<->symbols drop dup unpinargs ndrop r> ; 638 | 639 | : funcall-lambda ( arg1 arg2 ... argn n lambda -- x ) 640 | 2dup lambda-nargs = not if wrong-number-of-arguments then 641 | dup lambda-args swap lambda-body eval-with-bindings ; 642 | 643 | : funcall ( arg1 ... argn n function -- x) 644 | >r pinargs r> over >r 645 | dup #symbolp #if #symbol-function endif 646 | dup #subrp #if execute-subr else funcall-lambda endif 647 | r> unpinargs ; 648 | 649 | : #funcall ( function arg1 arg2 ... argn n+1 --- x ) 650 | 1- dup >r roll r> swap funcall ; 651 | 1 or-more function: funcall 652 | 653 | \ is X a macro? 654 | : macro? ( x -- bool) 655 | dup #symbolp #if safe-symbol-function endif 656 | dup #consp #not #if drop false exit endif 657 | #car [''] macro = ; 658 | 659 | : macroexpand-1* 660 | dup >r #cdr non-eval-args r> 661 | #car #symbol-function #cdr funcall ; 662 | 663 | : #macroexpand-1 ( list -- x ) 664 | dup #consp #not #if exit endif 665 | dup #car macro? if 666 | macroexpand-1* 667 | endif ; 668 | unary function: macroexpand-1 669 | 670 | \ Non-atoms 671 | 672 | : special: ( n parse:name -- ) 673 | false latestxt register-subr ; 674 | 675 | : #quote ( form -- form ) 676 | ; unary special: quote 677 | 678 | : ##if ( cond true false n -- form ) 679 | 2 = if nil endif 680 | rot eval-lisp-obj #if drop else nip endif eval-lisp-obj 681 | ; 2 3 special: if 682 | 683 | : #progn ( expr1 expr2 expr3 ... exprn n -- ) 684 | #list eval-progn-list 685 | ; 0 or-more special: progn 686 | 687 | : #%let ( symbols values expr1 ... exprn n+2 -- ) 688 | 2- #list swap -rot 2>r eval-and-unlist 2r> eval-with-bindings 689 | ; 2 or-more special: %let 690 | 691 | : eval-list-form 692 | dup #car macro? if 693 | #macroexpand-1 eval-lisp-obj 694 | else 695 | dup #car 696 | dup #symbolp #if #symbol-function endif 697 | dup special-subr? if 698 | >r #cdr non-eval-args r> execute-subr 699 | else 700 | >r #cdr eval-funcall-args r> funcall 701 | endif 702 | endif ; 703 | 704 | variable eval-depth 705 | -1 eval-depth ! 706 | : eval-indent eval-depth @ 3 * spaces ; 707 | 708 | : eval-form ( x -- y ) 709 | dup #integerp #if exit endif 710 | dup #symbolp #if #symbol-value exit endif 711 | dup #consp #if eval-list-form exit endif 712 | wrong-type-argument ; 713 | 714 | : #eval ( x -- y ) 715 | \ eval-depth 1+! 716 | \ ." ;; " eval-indent ." Evaluating " dup #print CR 717 | eval-form 718 | \ ." ;; " eval-indent ." => " dup #print CR 719 | \ eval-depth 1-! 720 | ; ' #eval is eval-lisp-obj 721 | unary function: eval 722 | 723 | 724 | \ REPL 725 | 726 | defer repl-function 727 | 728 | : repl-iteration #read #eval ; 729 | 730 | : user-repl-iteration ." * " query #read #eval >r attr red r> print-lisp-obj attr! CR ; 731 | 732 | : process-toplevels 733 | begin repl-function again ; 734 | 735 | \ Process Lisp forms until an error is signaled. 736 | : repl-loop ( repl-iteration-word -- ) 737 | ['] process-toplevels catch case 738 | 0 of endof 739 | 1 of ." ERROR: void variable" CR endof 740 | 2 of ." ERROR: void function" CR endof 741 | 3 of ." ERROR: wrong type of argument" CR endof 742 | 4 of ." ERROR: wrong number of arguments" CR endof 743 | 5 of ." ERROR: parsing error" CR endof 744 | \ 6 of endof EXIT 745 | \ 7 of endof EOF 746 | throw 747 | endcase ; 748 | 749 | \ Process forms until EXIT or EOF conditions. 750 | : toplevel 751 | ['] user-repl-iteration is repl-function 752 | begin 753 | ['] repl-loop catch case 754 | 6 of exit endof 755 | 7 of exit endof 756 | endcase 757 | again ; 758 | 759 | @lisp/core.lisp buffer>string 760 | :noname 761 | ['] repl-iteration is repl-function 762 | ['] repl-loop catch case 763 | 6 of endof 764 | 7 of endof 765 | endcase 766 | ; execute-parsing 767 | 768 | : run-lisp 769 | attr page 0 0 at-xy white ." RUNNING EULEX LISP." attr! CR CR 770 | refill-silent? on 771 | get-order get-current 772 | in-lisp-package: definitions 773 | end-newline-p on 774 | toplevel 775 | end-newline-p off 776 | set-current set-order 777 | refill-silent? off 778 | CR ." GOOD BYE!" CR CR ; 779 | 780 | \ Provide RUN-LISP in the system vocabulary 781 | set-current 782 | ' run-lisp alias run-lisp 783 | previous previous 784 | 785 | \ lisp.fs ends here 786 | -------------------------------------------------------------------------------- /math.fs: -------------------------------------------------------------------------------- 1 | \ math.fs -- Mathematical words 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | : gcd ( m n -- gcd[m,n] ) 21 | begin 22 | dup 0<> while 23 | tuck mod 24 | repeat 25 | drop 26 | ; 27 | 28 | : lcm ( m n -- lcm[m,n] ) 29 | 2dup * -rot gcd / ; 30 | 31 | 32 | : divisible ( m n -- flag ) 33 | mod 0= ; 34 | 35 | : fact ( n -- n! ) 36 | 1 swap 37 | 0 ?do 38 | i 1+ * 39 | loop ; 40 | 41 | \ math.fs ends here 42 | -------------------------------------------------------------------------------- /memory.fs: -------------------------------------------------------------------------------- 1 | \ memory.fs -- Heap allocation 2 | 3 | \ This file provides support for Forth words ALLOCATE, FREE and 4 | \ RESIZE by a simple first-fit strategy implementation. 5 | 6 | \ Copyright 2011,2012 (C) David Vazquez 7 | 8 | \ This file is part of Eulex. 9 | 10 | \ Eulex is free software: you can redistribute it and/or modify 11 | \ it under the terms of the GNU General Public License as published by 12 | \ the Free Software Foundation, either version 3 of the License, or 13 | \ (at your option) any later version. 14 | 15 | \ Eulex is distributed in the hope that it will be useful, 16 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | \ GNU General Public License for more details. 19 | 20 | \ You should have received a copy of the GNU General Public License 21 | \ along with Eulex. If not, see . 22 | 23 | require @string.fs 24 | require @structures.fs 25 | require @kernel/multiboot.fs 26 | 27 | \ Heap region memory limits. It covers from the end of the dictionary 28 | \ to the end of the upper memory as provided by the 29 | \ multiboot-compliant bootloader. 30 | dp-limit 2aligned constant heap-start 31 | mem-upper-limit 1- 2 cells - 2aligned constant heap-end 32 | 33 | heap-end heap-start - constant heap-size 34 | 35 | 36 | struct 37 | ( reserved ) cell noname field 38 | cell field chunk-size 39 | 0 field chunk>addr 40 | end-struct chunk-alloc% 41 | 42 | struct 43 | chunk-alloc% noname field 44 | cell field chunk-next \ used if it is free. 45 | cell field chunk-previous \ used if it is free. 46 | end-struct chunk% 47 | 48 | : chunk>size ( chunk -- u ) 49 | chunk-size @ ; 50 | : addr>chunk ( addr -- chunk ) 51 | chunk-alloc% - ; 52 | 53 | : chunk>end ( chunk -- ) 54 | dup chunk>addr swap chunk>size + ; 55 | 56 | \ Sentinel node. It is kept to make sure that there is always a first 57 | \ node in the list, which makes easier the implementation. 58 | heap-start constant sentinel-chunk-begin 59 | heap-end chunk% - constant sentinel-chunk-end 60 | 61 | : align-chunk-size ( u -- u* ) 62 | dup cell negate u<= if 63 | 2aligned 64 | else 65 | drop $ffffffff 66 | then ; 67 | 68 | : validate-chunk-size ( u -- u* ) 69 | align-chunk-size dup chunk% u<= if 70 | drop chunk% 71 | endif ; 72 | 73 | \ Note that all the following words work for available/free 74 | \ chunks. So, when you read `chunk' in the code, you should think 75 | \ about free chunk. However, some operations can be used on chunks of 76 | \ allocated memory. 77 | 78 | : next-chunk ( chunk -- next-chunk ) 79 | chunk-next @ ; 80 | 81 | : previous-chunk ( chunk -- previous-chunk ) 82 | chunk-previous @ ; 83 | 84 | : first-chunk ( -- chunk ) 85 | sentinel-chunk-begin next-chunk ; 86 | 87 | : first-chunk? ( chunk -- flag ) 88 | first-chunk = ; 89 | 90 | : last-chunk? ( chunk -- flag ) 91 | next-chunk sentinel-chunk-end = ; 92 | 93 | : null-chunk? ( chunk -- flag ) 94 | sentinel-chunk-end = ; 95 | 96 | : chunk-neighbours ( chunk -- previous next ) 97 | dup previous-chunk swap next-chunk ; 98 | 99 | : link-chunks ( chunk1 chunk2 -- ) 100 | 2dup swap chunk-next ! chunk-previous ! ; 101 | 102 | : enough-large-chunk? ( u chunk -- flag ) 103 | chunk>size u<= ; 104 | 105 | : find-enough-chunk ( u -- chunk ) 106 | first-chunk 107 | begin dup null-chunk? not while 108 | 2dup enough-large-chunk? if nip exit endif 109 | next-chunk 110 | repeat 111 | nip ; 112 | 113 | : preceding-chunk? ( addr chunk -- flag ) 114 | dup -rot next-chunk between ; 115 | 116 | : find-preceding-chunk ( addr -- chunk ) 117 | sentinel-chunk-begin 118 | begin 2dup preceding-chunk? not while 119 | next-chunk 120 | repeat 121 | nip ; 122 | 123 | : insert-chunk ( preceding chunk -- ) 124 | 2dup swap next-chunk link-chunks link-chunks ; 125 | 126 | : delete-chunk ( chunk -- ) 127 | chunk-neighbours link-chunks ; 128 | 129 | : adjust-chunk-size ( u chunk -- ) 130 | chunk-size ! ; 131 | 132 | : chunk-header ( start end -- chunk ) 133 | over - chunk-alloc% - swap tuck adjust-chunk-size ; 134 | 135 | : create-chunk ( start end -- ) 136 | chunk-header 137 | dup find-preceding-chunk 138 | swap tuck insert-chunk ; 139 | 140 | : expand-chunk ( u chunk -- ) 141 | tuck chunk>size + swap adjust-chunk-size ; 142 | 143 | : reduce-chunk ( u chunk -- ) 144 | swap negate swap expand-chunk ; 145 | 146 | : too-large-chunk? ( n chunk -- flag ) 147 | chunk>size swap chunk% + 2* u>= ; 148 | 149 | \ Resize CHUNK to U and return a new available new-chunk. 150 | : split-allocated-chunk ( u chunk -- new-chunk ) 151 | dup chunk>end >r 152 | tuck adjust-chunk-size 153 | chunk>end r> create-chunk ; 154 | 155 | : reserve-chunk ( u chunk -- new-chunk ) 156 | 2dup too-large-chunk? if 157 | dup delete-chunk tuck split-allocated-chunk drop 158 | else 159 | nip dup delete-chunk 160 | endif ; 161 | 162 | 163 | \ Coalescing 164 | 165 | : adjoint-chunks? ( chunk1 chunk2 -- flag ) 166 | swap chunk>end = ; 167 | 168 | : limit-chunks? ( chunk1 chunk2 -- flag ) 169 | first-chunk? swap last-chunk? or ; 170 | 171 | : coalescable? ( chunk1 chunk2 -- flag ) 172 | 2dup adjoint-chunks? -rot limit-chunks? not and ; 173 | 174 | : absorb-chunk ( chunk1 chunk2 -- ) 175 | chunk>size chunk-alloc% + swap expand-chunk ; 176 | 177 | : try-coalesce-chunks ( chunk1 chunk2 -- chunk ) 178 | 2dup coalescable? if 179 | 2dup absorb-chunk delete-chunk 180 | else 181 | drop 182 | endif ; 183 | 184 | : try-coalesce ( chunk -- chunk ) 185 | dup chunk-neighbours rot swap 186 | try-coalesce-chunks 187 | try-coalesce-chunks ; 188 | 189 | 190 | ( Initialization ) 191 | ( ) 192 | ( ) sentinel-chunk-begin chunk% 0 fill 193 | ( ) sentinel-chunk-end chunk% 0 fill 194 | ( ) sentinel-chunk-begin sentinel-chunk-end link-chunks 195 | ( ) 196 | ( ) sentinel-chunk-begin chunk% + 197 | ( ) sentinel-chunk-end 198 | ( ) create-chunk drop 199 | ( ) 200 | ( ----------------- ) 201 | 202 | : allocate ( u -- a-addr error ) 203 | validate-chunk-size 204 | dup find-enough-chunk 205 | dup null-chunk? if 206 | 2drop 0 -1 207 | else 208 | reserve-chunk chunk>addr 0 209 | endif ; 210 | 211 | : free ( a-addr -- error ) 212 | addr>chunk dup chunk>end create-chunk try-coalesce drop 0 ; 213 | 214 | 215 | : reallocate-memory ( addr1 addr2 u -- error ) 216 | \ Copy u bytes from ADDR1 to ADDR2 and free ADDR1. 217 | rot dup >r -rot move r> free ; 218 | 219 | : resize-with-reallocation ( addr u -- addr error ) 220 | dup allocate ?dup if 221 | 2>r 2drop 2r> 222 | else 223 | dup >r swap reallocate-memory r> swap 224 | endif ; 225 | 226 | : resize-without-reallocation ( addr u -- addr error ) 227 | swap addr>chunk 228 | 2dup too-large-chunk? if 229 | tuck split-allocated-chunk try-coalesce drop 230 | else 231 | nip 232 | endif 233 | chunk>addr 0 ; 234 | 235 | : resize ( a-addr u -- a-addr error ) 236 | validate-chunk-size 237 | over addr>chunk chunk>size over u< if 238 | resize-with-reallocation 239 | else 240 | resize-without-reallocation 241 | endif ; 242 | 243 | 244 | \ memory.fs ends here 245 | -------------------------------------------------------------------------------- /multiboot.h: -------------------------------------------------------------------------------- 1 | /* 2 | * multiboot.h - the header for Multiboot 3 | * 4 | * Copyright (C) 1999, 2001 Free Software Foundation, Inc. 5 | * 6 | * This file is part of Liphos. 7 | * 8 | * Liphos is free software; you can redistribute it and/or modify 9 | * it under the terms of the GNU General Public License as published by 10 | * the Free Software Foundation; either version 2 of the License, or 11 | * (at your option) any later version. 12 | * 13 | * Liphos is distributed in the hope that it will be useful, 14 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | * GNU General Public License for more details. 17 | * 18 | * You should have received a copy of the GNU General Public License 19 | * along with Liphos; if not, write to the Free Software 20 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 21 | * 22 | */ 23 | 24 | /* Macros. */ 25 | 26 | #ifndef _MULTIBOOT_H 27 | #define _MULTIBOOT_H 28 | 29 | /* The magic number for the Multiboot header. */ 30 | #define MULTIBOOT_HEADER_MAGIC 0x1BADB002 31 | 32 | 33 | /* The flags for the Multiboot header. */ 34 | #ifdef __ELF__ 35 | # define MULTIBOOT_HEADER_FLAGS 0x00000003 36 | #else 37 | # define MULTIBOOT_HEADER_FLAGS 0x00010003 38 | #endif 39 | 40 | /* The magic number passed by a Multiboot-compliant boot loader. */ 41 | #define MULTIBOOT_BOOTLOADER_MAGIC 0x2BADB002 42 | 43 | /* The size of our stack (16KB). */ 44 | #define STACK_SIZE 0x4000 45 | 46 | /* C symbol format. HAVE_ASM_USCORE is defined by configure. */ 47 | #ifdef HAVE_ASM_USCORE 48 | # define EXT_C(sym) _ ## sym 49 | #else 50 | # define EXT_C(sym) sym 51 | #endif 52 | 53 | #ifndef ASM 54 | 55 | 56 | /* Do not include here in boot.S. */ 57 | 58 | /* Types. */ 59 | 60 | /* The Multiboot header. */ 61 | typedef struct multiboot_header 62 | { 63 | unsigned long magic; 64 | unsigned long flags; 65 | unsigned long checksum; 66 | unsigned long header_addr; 67 | unsigned long load_addr; 68 | unsigned long load_end_addr; 69 | unsigned long bss_end_addr; 70 | unsigned long entry_addr; 71 | } multiboot_header_t; 72 | 73 | 74 | /* The symbol table for a.out. */ 75 | typedef struct aout_symbol_table 76 | { 77 | unsigned long tabsize; 78 | unsigned long strsize; 79 | unsigned long addr; 80 | unsigned long reserved; 81 | } aout_symbol_table_t; 82 | 83 | 84 | /* The section header table for ELF. */ 85 | typedef struct elf_section_header_table 86 | { 87 | unsigned long num; 88 | unsigned long size; 89 | unsigned long addr; 90 | unsigned long shndx; 91 | } elf_section_header_table_t; 92 | 93 | 94 | /* The Multiboot information. */ 95 | typedef struct multiboot_info 96 | { 97 | unsigned long flags; 98 | unsigned long mem_lower; 99 | unsigned long mem_upper; 100 | unsigned long boot_device; 101 | unsigned long cmdline; 102 | unsigned long mods_count; 103 | unsigned long mods_addr; 104 | union 105 | { 106 | aout_symbol_table_t aout_sym; 107 | elf_section_header_table_t elf_sec; 108 | } u; 109 | unsigned long mmap_length; 110 | unsigned long mmap_addr; 111 | } multiboot_info_t; 112 | 113 | 114 | /* The module structure. */ 115 | typedef struct module 116 | { 117 | unsigned long mod_start; 118 | unsigned long mod_end; 119 | unsigned long string; 120 | unsigned long reserved; 121 | } module_t; 122 | 123 | /* The memory map. Be careful that the offset 0 is base_addr_low 124 | but no size. */ 125 | typedef struct memory_map 126 | { 127 | unsigned long size; 128 | unsigned long base_addr_low; 129 | unsigned long base_addr_high; 130 | unsigned long length_low; 131 | unsigned long length_high; 132 | unsigned long type; 133 | } memory_map_t; 134 | 135 | 136 | #endif /* ! ASM */ 137 | 138 | #endif /* _MULTIBOOT_H */ 139 | -------------------------------------------------------------------------------- /output.fs: -------------------------------------------------------------------------------- 1 | \ output.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @kernel/console.fs 21 | 22 | : cr 10 emit ; 23 | : space 32 emit ; 24 | : spaces 25 | dup 0 > if 26 | 0 ?do space loop 27 | else 28 | drop 29 | then ; 30 | 31 | create .buffer 32 allot 32 | variable .index 33 | 34 | : sign 35 | 0< if 36 | [char] - emit 37 | then ; 38 | 39 | : a@ ( addr n -- x ) 40 | + c@ ; 41 | 42 | : a! ( x addr n -- ) 43 | + c! ; 44 | 45 | : emit-hex-digit 46 | dup 10 < if 47 | [char] 0 + 48 | else 49 | [char] A 10 - + 50 | then 51 | emit ; 52 | 53 | : .dump_buffer 54 | .index @ 0 ?do 55 | -1 .index +! 56 | .buffer .index @ a@ emit-hex-digit 57 | loop ; 58 | 59 | : print-number 60 | ?dup 0= if 61 | [char] 0 emit 62 | exit 63 | then 64 | dup sign abs 65 | .index 0! 66 | begin 67 | dup base @ mod .buffer .index @ a! 68 | 1 .index +! 69 | base @ / 70 | dup 0= until drop 71 | .dump_buffer ; 72 | 73 | 74 | : print-basis ( basis n -- ) 75 | base @ >r 76 | swap base ! print-number 77 | r> base ! ; 78 | 79 | : . print-number space ; 80 | 81 | : ? ( addr -- ) @ . ; 82 | 83 | : hex. 16 swap print-basis space ; 84 | : dec. 10 swap print-basis space ; 85 | : oct. 8 swap print-basis space ; 86 | 87 | : print-hex-byte ( n -- ) 88 | dup 16 / emit-hex-digit 89 | 16 mod emit-hex-digit 90 | ; 91 | 92 | : print-hex-number ( n -- ) 93 | [char] $ emit 94 | dup 28 rshift 15 and emit-hex-digit 95 | dup 24 rshift 15 and emit-hex-digit 96 | dup 20 rshift 15 and emit-hex-digit 97 | dup 16 rshift 15 and emit-hex-digit 98 | dup 12 rshift 15 and emit-hex-digit 99 | dup 8 rshift 15 and emit-hex-digit 100 | dup 4 rshift 15 and emit-hex-digit 101 | 0 rshift 15 and emit-hex-digit ; 102 | 103 | 104 | \ Strings 105 | 106 | : type ( addr n ) 107 | 0 ?do 108 | dup c@ emit 109 | 1+ 110 | loop 111 | drop 112 | ; 113 | 114 | : typewhite nip spaces ; 115 | 116 | : ." 117 | [compile] s" 118 | if-compiling 119 | postpone type 120 | else 121 | type 122 | then 123 | ; immediate 124 | 125 | : .( 126 | begin 127 | parse-char dup [char] ) <> while 128 | emit 129 | repeat 130 | drop 131 | ; immediate 132 | 133 | : id. nt>name type space ; 134 | 135 | \ output.fs ends here 136 | -------------------------------------------------------------------------------- /run-eulex.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | KERNEL=eulex 4 | 5 | QEMU=${QEMU:-$(command -v qemu-system-i386)} 6 | QEMU=${QEMU:-$(command -v qemu)} 7 | QEMU=${QEMU:-$(command -v qemu-system-x86_64)} 8 | 9 | if [ -z $QEMU ]; then 10 | echo "ERROR: qemu not found."; 11 | exit 1; 12 | fi 13 | 14 | $QEMU $@ -serial stdio -net none -kernel $KERNEL 15 | 16 | # run-eulex.sh ends here 17 | -------------------------------------------------------------------------------- /string.fs: -------------------------------------------------------------------------------- 1 | \ Strings 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | create read-string-buffer 256 allot 21 | variable read-string-index 22 | 23 | : rs, 24 | read-string-buffer read-string-index @ + c! 25 | read-string-index 1+! ; 26 | 27 | : read-string 28 | read-string-index 0! 29 | read-string-buffer 30 | 0 31 | begin 32 | parse-char 33 | dup [char] " <> while 34 | rs, 1+ 35 | repeat 36 | drop 37 | ; 38 | 39 | \ Store N bytes from ADDR to the dictionary. 40 | : s, ( addr n -- ) 41 | here over allot swap move ; 42 | 43 | \ Re-store a string in the dictionary. 44 | : string, ( addr n -- new-addr n ) 45 | here -rot tuck s, ; 46 | 47 | : s" 48 | \ Emit a branch before the string, we could be in a definition. 49 | if-compiling 50 | forward-branch 51 | endif 52 | read-string 53 | if-compiling 54 | string, 55 | rot here patch-forward-branch 56 | swap 57 | [compile] literal 58 | [compile] literal 59 | endif 60 | ; immediate 61 | 62 | 63 | : blank ( c-addr u - ) 64 | 32 fill ; 65 | 66 | 67 | \ Count the number of spaces from ADDR backward. 68 | : /string ( caddr1 u1 n - caddr2 u2 ) 69 | tuck - >r + r> ; 70 | 71 | : -trailing ( caddr u1 - caddr u2 ) 72 | begin 2dup 1- + c@ 32 = over 0<> and while 1- repeat ; 73 | 74 | : compare-integer ( m n -- p ) 75 | 2dup < if 76 | 2drop -1 77 | else 78 | > if 1 else 0 then 79 | then 80 | ; 81 | 82 | : compare ( caddr1 u1 caddr2 u2 -- n ) 83 | rot swap 2dup min -rot >r >r 84 | 0 ?do 85 | ( caddr1 cadddr2 ) 86 | over i + c@ 87 | over i + c@ 88 | compare-integer case 89 | -1 of 2drop unloop r> r> 2drop -1 exit endof 90 | 1 of 2drop unloop r> r> 2drop 1 exit endof 91 | 0 of endof 92 | endcase 93 | loop 94 | \ A string is included in the other, so we compare the lengths. 95 | 2drop r> r> compare-integer 96 | ; 97 | 98 | : string= ( caddr1 u1 caddr2 u2 -- flag ) 99 | compare 0= ; 100 | 101 | : string<> string= not ; 102 | 103 | \ Check if caddr2 u2 is a substring of caddr1 u1. 104 | : string-prefix? ( caddr1 u1 caddr2 u2 -- f ) 105 | rot 106 | 2dup > if 107 | 2drop 2drop false 108 | else 109 | drop dup -rot string= 110 | endif 111 | ; 112 | 113 | \ string.fs ends here 114 | -------------------------------------------------------------------------------- /structures.fs: -------------------------------------------------------------------------------- 1 | \ structures.fs --- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | 1 constant 8bits 21 | 2 constant 16bits 22 | 4 constant 32bits 23 | 24 | : struct 0 ; 25 | : field create swap dup , + does> @ + ; 26 | : end-struct constant ; 27 | 28 | \ structures.fs ends here 29 | -------------------------------------------------------------------------------- /tests/base.fs: -------------------------------------------------------------------------------- 1 | \ base.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | Checking simple arithmetics operations... 21 | 2 2 + 4 = assert 22 | 0 1 + 1 = assert 23 | 24 | Checking arithmetic carry and overflow... 25 | \ Positive tests 26 | :noname 500000000000 500000000000 + OF? nip assert ; execute 27 | :noname -500000000000 -500000000000 + OF? nip assert ; execute 28 | :noname 500000000000 2 * OF? nip assert ; execute 29 | :noname -500000000000 2 * OF? nip assert ; execute 30 | :noname -1 1 + CF? nip assert ; execute 31 | :noname 1 -1 + CF? nip assert ; execute 32 | \ Negative tests 33 | :noname 0 0 + OF? nip noassert ; execute 34 | :noname 0 0 - OF? nip noassert ; execute 35 | :noname 0 0 + CF? nip noassert ; execute 36 | :noname 0 0 - CF? nip noassert ; execute 37 | :noname -2 1 + CF? nip noassert ; execute 38 | :noname 100000000 100000000 + OF? nip noassert ; execute 39 | 40 | Checking simple logical operations... 41 | true true and true = assert 42 | true false and false = assert 43 | 44 | Checking 0-9 ascii consistency... 45 | char 0 46 | dup char 0 = assert 47 | 1+ dup char 1 = assert 48 | 1+ dup char 2 = assert 49 | 1+ dup char 3 = assert 50 | 1+ dup char 4 = assert 51 | 1+ dup char 5 = assert 52 | 1+ dup char 6 = assert 53 | 1+ dup char 7 = assert 54 | 1+ dup char 8 = assert 55 | 1+ dup char 9 = assert 56 | drop 57 | 58 | Checking A-F ascii consistency... 59 | char A 60 | dup char A = assert 61 | 1+ dup char B = assert 62 | 1+ dup char C = assert 63 | 1+ dup char D = assert 64 | 1+ dup char E = assert 65 | 1+ dup char F = assert 66 | drop 67 | 68 | Checking a-f ascii consistency... 69 | char a 70 | dup char a = assert 71 | 1+ dup char b = assert 72 | 1+ dup char c = assert 73 | 1+ dup char d = assert 74 | 1+ dup char e = assert 75 | 1+ dup char f = assert 76 | drop 77 | 78 | Checking simple stack words... 79 | clearstack depth 0= assert 80 | 81 | Checking bit word... 82 | 0 0 bit? false = assert 83 | 1 0 bit? true = assert 84 | 10 0 bit? false = assert 85 | 10 1 bit? true = assert 86 | 10 2 bit? false = assert 87 | 10 3 bit? true = assert 88 | 89 | Checking CASE word... 90 | : test-case ( n ) 91 | case 92 | 1 of 1000 endof 93 | 2 of 2000 endof 94 | 3 of 3000 endof 95 | \ Default 96 | 12345 swap 97 | endcase 98 | ; 99 | 1 test-case 1000 = assert 100 | 2 test-case 2000 = assert 101 | 3 test-case 3000 = assert 102 | 0 test-case 12345 = assert 103 | 104 | Checking some math words... 105 | 0 fact 1 = assert 106 | 1 fact 1 = assert 107 | 2 fact 2 = assert 108 | 3 fact 6 = assert 109 | 4 fact 24 = assert 110 | 5 fact 120 = assert 111 | 10 fact 3628800 = assert 112 | 113 | 0 0 gcd 0 = assert 114 | 0 1 gcd 1 = assert 115 | 1 0 gcd 1 = assert 116 | 12 8 gcd 4 = assert 117 | 118 | 1 1 lcm 1 = assert 119 | 2 3 lcm 6 = assert 120 | 3 2 lcm 6 = assert 121 | 12 6 lcm 12 = assert 122 | 12 8 lcm 24 = assert 123 | 124 | 125 | Checking recurse... 126 | : fact2 ( n -- n! ) 127 | dup 0> if 128 | dup 1- recurse * 129 | else 130 | drop 1 131 | endif ; 132 | 133 | 0 fact2 1 = assert 134 | 1 fact2 1 = assert 135 | 2 fact2 2 = assert 136 | 3 fact2 6 = assert 137 | 4 fact2 24 = assert 138 | 5 fact2 120 = assert 139 | 140 | 141 | Checking return stack operations... 142 | 143 | :noname 144 | 0 145 | >r r> 146 | 0= assert 147 | ; execute 148 | 149 | :noname 150 | 0 >r 151 | r@ 0= assert 152 | r> drop 153 | ; execute 154 | 155 | :noname 156 | rsp 157 | 0 >r r> drop 158 | rsp 159 | = assert 160 | ; execute 161 | 162 | :noname 163 | 0 1 164 | 2>r 2r> 165 | 1 = assert 166 | 0 = assert 167 | ; execute 168 | 169 | :noname 170 | 0 1 2>r 171 | r> 1 = assert 172 | r> 0 = assert 173 | ; execute 174 | 175 | 176 | Checking do-loop.... 177 | : foo 5 0 ?do i loop ; 178 | foo depth 5 = assert 179 | clearstack 180 | : foo 0 0 ?do i loop ; 181 | foo depth 0 = assert 182 | clearstack 183 | : foo 100 0 ?do i leave loop ; 184 | foo depth 1 = assert 185 | clearstack 186 | : foo 187 | 100 0 ?do 188 | i 9 = if 189 | i unloop exit 190 | else 191 | i 192 | endif 193 | loop 194 | ; 195 | foo depth 10 = assert 196 | clearstack 197 | 198 | Checking the stack is empty... 199 | depth 0= assert 200 | 201 | \ base.fs ends here 202 | -------------------------------------------------------------------------------- /tests/strings.fs: -------------------------------------------------------------------------------- 1 | \ strings.fs -- Tests 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | Checking equivalence of strings... 21 | :noname 22 | s" aaa" s" aaa" string= assert 23 | s" zzz" s" zzz" string= assert 24 | s" AAA" s" aaa" string<> assert 25 | s" ZZZ" s" aaa" string<> assert 26 | ; execute 27 | 28 | Checking string comparison... 29 | :noname 30 | s" aaa" s" zzz" compare -1 = assert 31 | s" zzz" s" aaa" compare 1 = assert 32 | s" abcd" s" abcde" compare -1 = assert 33 | s" abcde" s" abcd" compare 1 = assert 34 | ; execute 35 | 36 | Checking -trailing... 37 | :noname 38 | s" aaa" s" aaa " -trailing string= assert 39 | s" aaa" s" aaa" -trailing string= assert 40 | ; execute 41 | 42 | Checking /string... 43 | :noname 44 | s" xyz" s" abcxyz" 3 /string string= assert 45 | s" abcxyz" s" abcxyz" 0 /string string= assert 46 | ; execute 47 | 48 | Checking string-prefix?... 49 | :noname 50 | s" abc" s" abc" string-prefix? assert 51 | s" abcdef" s" abc" string-prefix? assert 52 | s" ab" s" abc" string-prefix? not assert 53 | s" xyz" s" abc" string-prefix? not assert 54 | ; execute 55 | 56 | 57 | \ strings.fs ends here 58 | -------------------------------------------------------------------------------- /tests/tests.fs: -------------------------------------------------------------------------------- 1 | \ Testing system 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | vocabulary test 21 | also test definitions 22 | 23 | variable check_failed 24 | variable total_passed 25 | variable total_failed 26 | 27 | : line input_source_line @ ; 28 | : column input_source_column @ ; 29 | 30 | : print-line line print-number ; 31 | : print-column column print-number ; 32 | 33 | : first-test? 34 | total_passed @ 35 | total_failed @ + 36 | 0= ; 37 | 38 | : check-sucessfully? 39 | first-test? if 40 | false 41 | else 42 | check_failed @ 0= 43 | then ; 44 | 45 | : report-previous-check 46 | check-sucessfully? if ." done" then ; 47 | 48 | : checking 49 | report-previous-check 50 | cr ." Checking " 51 | begin char dup 10 <> while 52 | emit 53 | repeat 54 | drop 55 | ; 56 | 57 | : assert 58 | not if 59 | cr 5 spaces ." - unexpected result in " print-line ." :" print-column 60 | total_failed 1+! 61 | check_failed 1+! 62 | else 63 | total_passed 1+! 64 | then ; 65 | 66 | : noassert 67 | not assert ; 68 | 69 | : report 70 | report-previous-check cr cr 71 | ." SUMMARY: " 72 | total_passed @ print-number 73 | ." /" 74 | total_passed @ 75 | total_failed @ + 76 | print-number 77 | ." tests were passed." cr 78 | ; 79 | 80 | : run-tests 81 | check_failed 0! 82 | total_passed 0! 83 | total_failed 0! 84 | also test 85 | @tests/tsuite.fs load-buffer 86 | report 87 | previous ; 88 | 89 | previous definitions 90 | 91 | \ tests.fs ends here 92 | -------------------------------------------------------------------------------- /tests/tsuite.fs: -------------------------------------------------------------------------------- 1 | \ tsuite.fs 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | @tests/base.fs load-buffer 21 | @tests/strings.fs load-buffer 22 | 23 | \ tsuite ends here 24 | -------------------------------------------------------------------------------- /tools.fs: -------------------------------------------------------------------------------- 1 | \ tools.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | : addr-column 21 | attr gray swap print-hex-number [char] : emit space attr! ; 22 | 23 | \ Dump n bytes of the memory from ADDR, in a readable way. 24 | : dump ( addr n -- ) 25 | 0 ?do 26 | i 16 mod 0= if 27 | cr dup i + addr-column 28 | then 29 | dup i + c@ print-hex-byte space 30 | loop drop 31 | cr 32 | ; 33 | 34 | : map-nt ( xt -- ) 35 | >r 36 | context @ dowords 37 | dup r@ execute 38 | endwords 39 | r> drop ; 40 | 41 | : words ['] id. map-nt ; 42 | 43 | : room-count ( -- n ) 44 | 0 context @ dowords swap 1+ swap endwords ; 45 | : room 46 | CR 47 | ." Words in the context: " room-count . CR 48 | ." Dictionary space allocated: " dp dp-base - . ." bytes" cr ; 49 | 50 | 51 | \ Display the content of the variable ADDR. 52 | : ? ( addr -- ) 53 | @ . ; 54 | 55 | 56 | \ Display the data stack 57 | : .s 58 | ." <" depth print-number ." > " 59 | sp-limit 60 | begin 61 | cell - 62 | dup sp cell + > while 63 | dup @ . 64 | repeat 65 | drop ; 66 | 67 | 68 | : unfind-in-wordlist ( xt wordlist -- addr c ) 69 | dowords 70 | 2dup nt>xt = if 71 | nip nt>name 72 | exit 73 | then 74 | endwords 75 | drop 76 | 0 0 ; 77 | 78 | \ Find the first avalaible word whose CFA is XT, pushing the name to 79 | \ the stack or two zeros if it is not found. 80 | : unfind ( xt -- addr u ) 81 | get-order dup 1+ roll 82 | ( widn ... wid1 n xt ) 83 | begin 84 | over 0<> while 85 | swap 1- swap rot 86 | over swap unfind-in-wordlist 87 | dup 0= if 88 | 2drop 89 | else 90 | >r >r 91 | drop 0 ?do drop loop 92 | r> r> 93 | exit 94 | then 95 | repeat 96 | 2drop 97 | 0 0 98 | ; 99 | 100 | \ Backtrace! 101 | 102 | : upper@ ( addr -- x|0) 103 | dup mem-upper-size u< if @ else drop 0 endif ; 104 | 105 | : retaddr>xt ( x -- ) 106 | dup cell - upper@ + ; 107 | 108 | : backtrace-frame ( addr -- flag ) 109 | retaddr>xt unfind dup 0<> if 110 | 2 spaces type cr true 111 | else 112 | type false 113 | endif ; 114 | 115 | \ Display the current backtrace. 116 | variable backtrace-limit 117 | 10 backtrace-limit ! 118 | : backtrace 119 | ." Backtrace: " cr 120 | backtrace-limit @ 121 | rsp 122 | begin over 0<> over rsp-limit <= and while 123 | dup @ backtrace-frame if swap 1- swap endif 124 | cell + 125 | repeat 126 | drop ; 127 | 128 | 129 | ( Display the list of vocabularies in the system and the search order stack ) 130 | 131 | : .wid ( wid -- ) 132 | wid>name ?dup if type space else ." ??? " drop then ; 133 | 134 | : vocs 135 | last-wid @ 136 | begin ?dup while 137 | dup .wid 138 | wid-previous @ 139 | repeat ; 140 | 141 | : order 142 | get-order 0 ?do .wid loop 4 spaces current @ .wid ; 143 | 144 | Root definitions 145 | ' order alias order 146 | ' words alias words 147 | previous definitions 148 | 149 | ( Disassembler. SEE ) 150 | require @disassem.fs 151 | 152 | 153 | \ Dynamic memory management debugging 154 | 155 | : .chunk ( chunk -- ) 156 | ." Base: " dup chunk>addr print-hex-number 5 SPACES 157 | ." End: " dup chunk>end print-hex-number 5 SPACES 158 | ." Size: " chunk>size print-hex-number CR ; 159 | 160 | : meminfo 161 | CR first-chunk 162 | begin dup null-chunk? not while 163 | dup .chunk 164 | next-chunk 165 | repeat 166 | drop ; 167 | 168 | 169 | \ tools.fs ends here 170 | -------------------------------------------------------------------------------- /user.fs: -------------------------------------------------------------------------------- 1 | \ user.fs -- 2 | 3 | \ Copyright 2011 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | page 21 | attr white ." Welcome to Eulex!" attr! cr 22 | cr 23 | ." Copyright (C) 2011,2012 David Vazquez" cr 24 | ." This is free software; see the source for copying conditions. There is NO" cr 25 | ." warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." cr cr 26 | 27 | : license 28 | cr 29 | ." This program is free software; you can redistribute it and/or modify" cr 30 | ." it under the terms of the GNU General Public License as published by" cr 31 | ." the Free Software Foundation; either version 3 of the License, or" cr 32 | ." (at your option) any later version." cr 33 | cr 34 | ." This program is distributed in the hope that it will be useful," cr 35 | ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr 36 | ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr 37 | ." GNU General Public License for more details." cr 38 | cr 39 | ." You should have received a copy of the GNU General Public License" cr 40 | ." along with this program. If not, see http://www.gnu.org/licenses/." cr ; 41 | 42 | 43 | variable error-message 44 | variable error-message-size 45 | 46 | : exception-message ( -- addr u ) 47 | error-message @ 48 | error-message-size @ ; 49 | : exception-message! ( addr u -- ) 50 | error-message-size ! 51 | error-message ! ; 52 | 53 | : (abort)" exception-message! -2 throw ; 54 | 55 | : abort" 56 | postpone if 57 | postpone s" 58 | postpone (abort)" 59 | postpone then 60 | ; immediate compile-only 61 | 62 | : catch-errors ( xt -- ) 63 | %catch-without-unwind ?dup 0<> if 64 | cr attr red ." ERROR: " attr! 65 | attr white swap 66 | case 67 | -1 of ." Aborted" cr endof 68 | -2 of exception-message type CR endof 69 | -3 of ." Stack overflow" cr endof 70 | -4 of ." Stack underflow" cr endof 71 | -10 of ." Division by zero" cr endof 72 | -13 of ." Unknown word" cr endof 73 | -14 of ." Compile-only word" cr endof 74 | ." Ocurred an unexpected error of code " dup . cr 75 | endcase 76 | white ." >>>" read_word_buffer count type ." <<<" cr 77 | attr! 78 | backtrace 79 | state 0! 80 | clearstack 81 | then 82 | %unwind-after-catch ; 83 | 84 | :noname @eulexrc.fs require-buffer ; 85 | : load-eulexrc catch-errors ; 86 | 87 | : user-interaction query interpret ; 88 | : user-interaction-loop 89 | begin ['] user-interaction catch-errors again ; 90 | 91 | : start-user-interaction 92 | only forth definitions also 93 | load-eulexrc 94 | user-interaction-loop ; 95 | 96 | 97 | \ Export words to the Forth vocabulary 98 | 99 | : clone-word ( nt -- ) 100 | dup nt>name nextname 101 | dup nt>xt alias 102 | nt>flags @ latest nt>flags ! ; 103 | 104 | : } 105 | set-current ; 106 | 107 | : FORTH{ 108 | get-current 109 | forth-wordlist set-current 110 | begin 111 | NT' 112 | dup [NT'] } <> while 113 | clone-word 114 | repeat 115 | nt>xt execute ; 116 | 117 | FORTH{ 118 | ! ' ( ) * + +! +loop , - -rot -trailing . ." .( .s / /mod /string 0! 119 | 0< 0<> 0= 0> 1+ 1- 2* 2+ 2- 2>r 2drop 2dup 2nip 2over 2r> 2r@ 2rot 120 | 2swap 2tuck : :noname ; < <= <> = > >= >in >order >r ? ?do ?dup @ 121 | Forth Only Root [ ['] [char] [compile] [defined] [else] [endif] [if] 122 | [ifdef] [ifundef] [then] \ ] ]L abort abort" abs accept again alias 123 | align aligned allocate allot also and at-xy base beep begin blank c! 124 | c, c@ case catch cell cell+ cells char char+ chars clearstack cmove 125 | cmove> compare compile, compile-only constant context count cr create 126 | current dec. decimal defer definitions depth do does> drop dump dup 127 | edit-line else emit end-struct endcase endif endof eulex evaluate 128 | execute exit false field fill free gcd get-current get-order here hex 129 | hex. i id. if immediate invert is j k key latest latestxt lcm leave 130 | literal loop lshift max marker min mod move ms negate nextname nip 131 | noname noop not oct. octal of off on or order over pad page parse-name 132 | pick postpone previous query r> r@ reboot recurse recursive refill 133 | repeat restore-input resize roll room rot rshift s" save-input see 134 | set-current set-order sign source source-id space spaces state 135 | string-prefix? string<> string= struct swap then throw tib to true 136 | tuck type typewhite u< unloop until value variable vocabulary vocs w! 137 | w@ while wordlist words xor 138 | } 139 | 140 | require @editor.fs 141 | 142 | START-USER-INTERACTION 143 | 144 | \ user.fs ends here 145 | -------------------------------------------------------------------------------- /vocabulary.fs: -------------------------------------------------------------------------------- 1 | \ vocabulary.fs -- 2 | 3 | \ Copyright 2011, 2012 (C) David Vazquez 4 | 5 | \ This file is part of Eulex. 6 | 7 | \ Eulex is free software: you can redistribute it and/or modify 8 | \ it under the terms of the GNU General Public License as published by 9 | \ the Free Software Foundation, either version 3 of the License, or 10 | \ (at your option) any later version. 11 | 12 | \ Eulex is distributed in the hope that it will be useful, 13 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | \ GNU General Public License for more details. 16 | 17 | \ You should have received a copy of the GNU General Public License 18 | \ along with Eulex. If not, see . 19 | 20 | require @structures.fs 21 | 22 | variable last-wid 23 | 24 | struct 25 | cell field wid-latest 26 | cell field wid-method 27 | cell field wid-name 28 | cell field wid-previous 29 | end-struct wid% 30 | 31 | : wid>latest wid-latest @ ; 32 | 33 | : wid>name ( wid -- addr n ) 34 | wid-name @ ?dup if count else 0 0 then ; 35 | 36 | : context 37 | sorder_stack sorder_tos @ cells + ; 38 | 39 | context @ constant forth-impl-wordlist 40 | : forth-impl 41 | forth-impl-wordlist context ! ; 42 | forth-impl-wordlist last-wid ! 43 | 44 | : get-order ( -- widn .. wid1 n ) 45 | sorder_stack 46 | sorder_tos @ 1+ 0 ?do 47 | dup @ swap cell + 48 | loop 49 | drop 50 | sorder_tos @ 1+ ; 51 | 52 | : set-order ( widn .. wid1 n -- ) 53 | dup 0= if 54 | sorder_tos 0! 55 | forth-impl 56 | drop 57 | else 58 | dup 1- sorder_tos ! 59 | context swap 60 | 0 ?do 61 | dup -rot ! cell - 62 | loop 63 | drop 64 | then ; 65 | 66 | : get-current current @ ; 67 | : set-current current ! ; 68 | 69 | : previous 70 | sorder_tos @ 1 >= if sorder_tos 1-! then ; 71 | 72 | : definitions 73 | context @ current ! ; 74 | 75 | : allocate-wordlist ( -- wid ) 76 | here wid% zallot ; 77 | 78 | : wordlist ( -- wid ) 79 | here allocate-wordlist last-wid @ over wid-previous ! last-wid ! ; 80 | 81 | : also 82 | sorder_tos @ sorder_size < if 83 | context @ 84 | sorder_tos 1+! 85 | context ! 86 | \ This is commented because we have not ." in this point. 87 | \ else 88 | \ ." ERROR: Too wordlists in the search order stack." cr 89 | then 90 | ; 91 | 92 | : >order ( wid -- ) 93 | also context ! ; 94 | 95 | \ DOWORDS ... ENDWORDS 96 | \ 97 | \ A loop construction to iterate on the words in a wordlist. The body 98 | \ is executed with a NT on the TOS each time. You MUST NOT remove this 99 | \ element from the stack. 100 | : dowords 101 | postpone wid>latest 102 | postpone begin 103 | postpone ?dup 104 | postpone while 105 | ; immediate compile-only 106 | : endwords 107 | postpone previous-word 108 | postpone repeat 109 | ; immediate compile-only 110 | 111 | \ Vocabularies 112 | 113 | : vocabulary 114 | create latest nt>cname wordlist wid-name ! does> context ! ; 115 | 116 | \ Define Forth and Root vocabularies 117 | wordlist constant forth-wordlist 118 | wordlist constant root-wordlist 119 | 120 | : Forth forth-wordlist context ! ; 121 | : Root root-wordlist >order ; 122 | : Eulex forth-impl ; 123 | 124 | nt' Forth nt>cname forth-wordlist wid-name ! 125 | nt' Root nt>cname root-wordlist wid-name ! 126 | nt' Eulex nt>cname forth-impl-wordlist wid-name ! 127 | 128 | : only sorder_tos 0! root-wordlist context ! also ; 129 | 130 | Root definitions 131 | ' set-order alias set-order 132 | ' forth-wordlist alias forth-wordlist 133 | ' eulex alias eulex 134 | ' forth alias forth 135 | previous definitions 136 | 137 | \ vocabulary.fs ends here 138 | --------------------------------------------------------------------------------