diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 4832c3b..0000000 --- a/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -bin/ -obj/ -*.swp diff --git a/Makefile b/Makefile deleted file mode 100644 index c4bd48c..0000000 --- a/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -# ------------------------------------------------ -# Forthress, a Forth dialect -# -# Author: igorjirkov@gmail.com -# Date : 02-04-2018 -# -# ------------------------------------------------ - -ASM = nasm -ASMFLAGS = -felf64 -g -Isrc/ - - -NATIVE_CALLS_SUPPORT=1 - -# This feature allows you to call functions from libc and other shared libraries. -# You get support for native calls by address and dlsym. -ifdef NATIVE_CALLS_SUPPORT -LINKERFLAGS = -nostdlib -LIBS = -ldl -LINKER = gcc -ASMFLAGS += -DNATIVE_CALLS -else -LINKER = ld -LINKERFLAGS = -LIBS = -endif - - -all: bin/forthress - -bin/forthress: obj/forthress.o obj/util.o - mkdir -p bin - $(LINKER) -o bin/forthress $(LINKERFLAGS) -o bin/forthress obj/forthress.o obj/util.o $(LIBS) - -obj/forthress.o: src/forthress.asm src/macro.inc src/words.inc src/util.inc - mkdir -p obj - $(ASM) $(ASMFLAGS) src/forthress.asm -o obj/forthress.o - -obj/util.o: src/util.inc src/util.asm - mkdir -p obj - $(ASM) $(ASMFLAGS) src/util.asm -o obj/util.o - -clean: - rm -rf build obj - -.PHONY: clean - diff --git a/doc-engine.frt b/doc-engine.frt deleted file mode 100644 index 99212f4..0000000 --- a/doc-engine.frt +++ /dev/null @@ -1,74 +0,0 @@ -( -This file implements Forthress documentation engine. To use it, place a -string on the stack before defining a new word, and use `wit-doc` after -semicolon to create documentation entry for the last word defined. -) - -global doc-start -0 doc-start ! - -struct - cell% field >doc-next - cell% field >doc-addr - cell% field >doc-string -end-struct doc-header% - -( word-address docstring ) -: doc-word - swap - doc-header% allot >r - swap - r@ >doc-string ! - doc-start @ r@ >doc-next ! - r@ >doc-addr ! - r> doc-start ! -; - -( string - ) -: with-doc last_word @ cfa swap doc-word ; - -g" -( addr - doc-header? ) -Given an XT of a word, finds a relevant `doc-header` in the documentation DB -" -: doc-find - doc-start @ - repeat - dup 0 = if 2drop 0 1 ( return 0 ) - else - 2dup >doc-addr @ = if - swap drop 1 - else >doc-next @ 0 - then - then - until -; with-doc - -g" -( addr - ) -Display documentation for the word address -" -: doc-show dup doc-find dup if - >doc-string @ dup if - cr - ." # Documentation for " swap ? cr - prints cr - ." ------" cr - else 2drop ." Error: empty documentation string " then - else drop ." No documentation for " ? cr then -; with-doc - -g" -Alias for `doc-show` -" -: ?? doc-show ; with-doc - -' doc-word g" -( word-address docstring ) -Document an existing word with a documenting string. Prefer using global strings for that matter. -" doc-word - -' doc-start g" -Global variable storing the address of documentation database. -The database itself is a linked list of `doc-header` structures. -" doc-word diff --git a/documentation.frt b/documentation.frt deleted file mode 100644 index c8ea719..0000000 --- a/documentation.frt +++ /dev/null @@ -1,14 +0,0 @@ -' dup g" -( a - a a ) -Duplicate the cell on top of the stack. -" doc-word - -' drop g" -( a -- ) -Drop the topmost element of the stack -" doc-word - -' swap g" -( a b -- b a ) -Swap two topmost elements of the stack -" doc-word diff --git a/LICENSE b/forthress/LICENSE similarity index 100% rename from LICENSE rename to forthress/LICENSE diff --git a/forthress/Makefile b/forthress/Makefile new file mode 100644 index 0000000..0b4912f --- /dev/null +++ b/forthress/Makefile @@ -0,0 +1,30 @@ +# ------------------------------------------------ +# Forthress, a Forth dialect +# +# Author: igorjirkov@gmail.com +# Date : 15-10-2016 +# +# ------------------------------------------------ + +ASM = nasm +FLAGS = -felf64 -g -Isrc/ +LINKER = ld + +all: bin/forthress + +bin/forthress: obj/forthress.o obj/util.o + mkdir -p bin + ld -o bin/forthress obj/forthress.o obj/util.o + +obj/forthress.o: src/forthress.asm src/macro.inc src/words.inc src/util.inc + mkdir -p obj + $(ASM) $(FLAGS) src/forthress.asm -o obj/forthress.o + +obj/util.o: src/util.inc src/util.asm + mkdir -p obj + $(ASM) $(FLAGS) src/util.asm -o obj/util.o +clean: + rm -rf build obj + +.PHONY: clean + diff --git a/README.md b/forthress/README.md similarity index 96% rename from README.md rename to forthress/README.md index e5734f7..54ed208 100644 --- a/README.md +++ b/forthress/README.md @@ -33,12 +33,12 @@ Programming: C, Assembly, and Program Execution on Intel x86-64 Architecture"](h * `dup` ( a -- a a ) * `rot` ( a b c -- b c a ) * Arithmetic: - * `+` ( x y-- [ x + y ] ) - * `*` ( x y-- [ x * y ] ) - * `/` ( x y-- [ x / y ] ) - * `%` ( x y-- [ x mod y ] ) - * `-` ( x y-- [x - y] ) - * `<` ( x y-- [x < y] ) + * `+` ( y x -- [ x + y ] ) + * `*` ( y x -- [ x * y ] ) + * `/` ( y x -- [ x / y ] ) + * `%` ( y x -- [ x mod y ] ) + * `-` ( y x -- [x - y] ) + * `<` ( y x -- [x < y] ) * Logic: * `not` ( a -- a' ) a' = 0 if a != 0 @@ -142,12 +142,12 @@ Prints a certain amount of characters from string. ( addr -- value ) Fetch value from memory. * `!` - ( val addr -- ) + ( addr val -- ) Store value by address. -* `c!` - ( char addr -- ) +* `!c` + ( addr char -- ) Store one byte by address. -* `c@` +* `@c` ( addr -- char ) Read one byte starting at addr. * `,` diff --git a/diagnostics.frt b/forthress/diagnostics.frt similarity index 100% rename from diagnostics.frt rename to forthress/diagnostics.frt diff --git a/forthress/documentation.frt b/forthress/documentation.frt new file mode 100644 index 0000000..030d98a --- /dev/null +++ b/forthress/documentation.frt @@ -0,0 +1,114 @@ +' dup g" +( a - a a ) +Duplicate the cell on top of the stack. +" doc-word + +' drop g" +( a -- ) +Drop the topmost element of the stack. +" doc-word + +' swap g" +( a b -- b a ) +Swap two topmost elements of the stack. +" doc-word + +' 2over g" +( a b c -- a b c a ) +Copy third element from the top of the stack to the top of the stack. +" doc-word + +' 2drop g" +( a b -- ) +Drop 2 elements from the top of the stack. +" doc-word + +' ( g" +Start a comment. Reads from input stream until ) symbol. +" doc-word + +' readc g" +Read char from input stream. +" doc-word + +' readc@ g" +Read char from an open fd. +" doc-word + +' sys-write g" +Perform write syscall. +" doc-word + +' sys-read g" +Perform read syscall. +" doc-word + +' sys-write-no g" + Constant used in sys-write. +" doc-word + +' sys-read-no g" +Constant used in sys-read. +" doc-word + +' loop g" +End of do ... loop block. do loop block reads limit and index from the top of the stack and repeats block of code between do and loop (limit - index) times. +" doc-word + +' do g" +Begin of do ... loop block. do loop block reads limit and index from the top of the stack and repeats block of code between do and loop (limit - index) times. +" doc-word + +' endfor g" +End of for ... endfor block. Similar to do ... loop block, but will perform at least once if index is more than limit. +" doc-word + +' for g" +Begin of for ... endfor block. Similar to do ... loop block, but will perform at least once if index is more than limit. +" doc-word + +' until g" +End of repeat ... until block. At the end of each iteration, checks number at the top of the stack? If it is 0, then remove it and start the loop again; if not zero, then remove it and exit the loop. +" doc-word + +' repeat g" +Begin of repeat ... until block. At the end of each iteration, checks number at the top of the stack? If it is 0, then remove it and start the loop again; if not zero, then remove it and exit the loop. +" doc-word + +' endif g" +Exit if ... then block. +" doc-word + +' then g" +End of if ... then block. +" doc-word + +' else g" +Used indide if ... then block. Perform the body if the top of the stack is zero. +" doc-word + +' if g" +Begin of if ... then block. Perform the body if the top of the stack is non-zero. +" doc-word + +' again g" +Performs unconditional branch to the previous begin block. +" doc-word + +' begin g" +Begin of begin ... again block. +" doc-word + +' allot g" +Accept the number of bytes to allocate in the global data area. +" doc-word + +' KB g" +( a -- a * 1024) +Multiply the topmost element of the stack by 1024. +" doc-word + +' MB g" +( a -- a * 1048576) +Multiply the topmost element of the stack by 1024 twice. +" doc-word \ No newline at end of file diff --git a/fib.frt b/forthress/fib.frt similarity index 93% rename from fib.frt rename to forthress/fib.frt index 09880bc..7332ae4 100644 --- a/fib.frt +++ b/forthress/fib.frt @@ -26,3 +26,9 @@ _______ then ; +: prime ; + +: perfect-sq ; + + + diff --git a/hash.frt b/forthress/hash.frt similarity index 100% rename from hash.frt rename to forthress/hash.frt diff --git a/heap.frt b/forthress/heap.frt similarity index 100% rename from heap.frt rename to forthress/heap.frt diff --git a/managed-string.frt b/forthress/managed-string.frt similarity index 58% rename from managed-string.frt rename to forthress/managed-string.frt index 0ce84de..7b10e05 100644 --- a/managed-string.frt +++ b/forthress/managed-string.frt @@ -2,10 +2,10 @@ mtype string mend 1 string >meta-is-value ! -: string-show ." Str: " QUOTE emit prints QUOTE emit ." \"" ; +: string-show ." Str: " QUOTE prints QUOTE ." \"" ; ' string-show string >meta-printer ! : m" ' h" execute compiling if ' dup , ' string , ' manage , - else dup string manage then ; IMMEDIATE + else dup string manage then ; diff --git a/mmap.frt b/forthress/mmap.frt similarity index 100% rename from mmap.frt rename to forthress/mmap.frt diff --git a/forthress/part1/collatz_sequence.frt b/forthress/part1/collatz_sequence.frt new file mode 100644 index 0000000..627d767 --- /dev/null +++ b/forthress/part1/collatz_sequence.frt @@ -0,0 +1,30 @@ +: is_even 2 % not ; + +: inc 1 + ; + +: collatz + dup 1 < if drop ." Illegal argument. Number must be positive integer" + else + dup >r + repeat + dup 1 > if + dup is_even if + dup 2 / + else + dup 3 * inc + then + else 1 + then + dup 1 = until + then + r> +; IMMEDIATE + +: print_collatz + >r + repeat + dup . ." " + r@ = + until + cr r> drop +; \ No newline at end of file diff --git a/forthress/part1/concat.frt b/forthress/part1/concat.frt new file mode 100644 index 0000000..1adbe68 --- /dev/null +++ b/forthress/part1/concat.frt @@ -0,0 +1,19 @@ +: cp + repeat + over over + c@ swap c! + 1 + swap 1 + swap + dup c@ not + until +; + +: cat + over count over count + 1 + + heap-alloc + rot over + >r + cp drop swap + cp drop 0 swap + c! + r> prints +; IMMEDIATE \ No newline at end of file diff --git a/forthress/part1/parity.frt b/forthress/part1/parity.frt new file mode 100644 index 0000000..bff8d42 --- /dev/null +++ b/forthress/part1/parity.frt @@ -0,0 +1 @@ +: is_even 2 % not ; IMMEDIATE diff --git a/forthress/part1/prime.frt b/forthress/part1/prime.frt new file mode 100644 index 0000000..e8cbf86 --- /dev/null +++ b/forthress/part1/prime.frt @@ -0,0 +1,11 @@ +: is_prime + dup 2 < if ." Incorrect argument. Must be positive integer greater than 1" else + 1 >r + repeat + dup + r> 1 + dup >r + % 0 = + until + r> = + then +; IMMEDIATE diff --git a/forthress/part_2/Makefile b/forthress/part_2/Makefile new file mode 100644 index 0000000..acb36b2 --- /dev/null +++ b/forthress/part_2/Makefile @@ -0,0 +1,36 @@ +ASM = nasm +ASMFLAGS = -felf64 -g -I + + +NATIVE_CALLS_SUPPORT=1 + +ifdef NATIVE_CALLS_SUPPORT +LINKERFLAGS = -nostdlib +LIBS = -ldl +LINKER = gcc +ASMFLAGS += -DNATIVE_CALLS +else +LINKER = ld +LINKERFLAGS = +LIBS = +endif + + +all: bin/forthress + +bin/forthress: obj/forthress.o obj/util.o + mkdir -p bin + $(LINKER) -o bin/forthress $(LINKERFLAGS) -o bin/forthress obj/forthress.o obj/util.o $(LIBS) + +obj/forthress.o: forthress.asm macro.inc words.inc util.inc + mkdir -p obj + $(ASM) $(ASMFLAGS) forthress.asm -o obj/forthress.o + +obj/util.o: util.inc util.asm + mkdir -p obj + $(ASM) $(ASMFLAGS) util.asm -o obj/util.o + +clean: + rm -rf build obj + +.PHONY: clean \ No newline at end of file diff --git a/forthress/part_2/bin/forthress b/forthress/part_2/bin/forthress new file mode 100644 index 0000000..b0ebaea Binary files /dev/null and b/forthress/part_2/bin/forthress differ diff --git a/forthress/part_2/forthress.asm b/forthress/part_2/forthress.asm new file mode 100644 index 0000000..8a46c16 --- /dev/null +++ b/forthress/part_2/forthress.asm @@ -0,0 +1,123 @@ +global _start +global last_word + +%include "util.inc" +%include "macro.inc" + +%define w r15 +%define pc r14 +%define rstack r13 + +%define is_immediate 1 +%define is_branch 2 + +section .rodata +msg_stack_underflow: db 'stack underflow',10, 0 +msg_word_undefined: db 'no such word',10, 0 + +section .data +program_stub: dq 0 +xt_interpreter: dq .interpreter +.interpreter: dq interpreter_loop +current_word: times 256 db 0, 0 +stack_head: dq 0 +p_cmp_flag: dq 0 +state: dq 0 + +section .bss +user_mem: resq 65536 +user_dict: resq 65536 +return_stack: resq 1024 + +section .text +%include "words.inc" + +next: + mov w, pc + add pc, 8 + mov w, [w] + jmp [w] + +interpreter_loop: + mov rsi, 256 + mov rdi, current_word + call read_word + test rdx, rdx + jz .exit + mov rdi, rax + call find_word + cmp byte [state], 0 + jne .compile + test rax, rax + jz .undef + mov rdi, rax + call cfa + +.interpret_word: + mov [program_stub], rax + mov pc, program_stub + jmp next + +.undef: + mov rdi, current_word + call parse_int + test rdx, rdx + jz .not_found + push rax + jmp interpreter_loop + +.not_found: + mov rdi, msg_word_undefined + call print_string + jmp interpreter_loop + +.compile: + test rax, rax + jz .not_compile + mov rdi, rax + call cfa + lea rdx, [rax - 1] + movzx rdx, byte [rdx] + mov [p_cmp_flag], rdx + cmp rdx, is_immediate + je .interpret_word + mov rdx, [here] + mov [rdx], rax + add qword [here], 8 + jmp interpreter_loop + +.not_compile: + mov rdi, current_word + call parse_int + test rdx, rdx + jz .not_found + cmp byte[p_cmp_flag], is_branch + je .branch + mov rcx, xt_lit + mov rdx, [here] + mov qword[rdx], rcx + add qword[here], 8 + mov rdx, [here] + mov [rdx], rax + add qword[here], 8 + jmp interpreter_loop + +.branch: + mov rdx, [here] + mov [rdx], rax + add qword [here], 8 + jmp interpreter_loop + +.exit: + xor rdi, rdi + call exit + +_start: + mov rstack, return_stack + mov [stack_head], rsp + mov pc, xt_interpreter + jmp next + +section .data +here: dq user_dict +last_word: dq _lw diff --git a/forthress/part_2/macro.inc b/forthress/part_2/macro.inc new file mode 100644 index 0000000..db26d7f --- /dev/null +++ b/forthress/part_2/macro.inc @@ -0,0 +1,62 @@ +%define _lw 0 +%macro native 3 + section .data + wh_ %+ %2 : dq _lw + db %1, 0 + db %3 + + %define _lw wh_%+ %2 + xt_ %+ %2 : dq i_ %+ %2 + section .text + i_ %+ %2: +%endmacro + +%macro native 2 +native %1, %2, 0 +%endmacro + +%macro colon 3 +section .data + wh_ %+ %2 : dq _lw + %define _lw wh_ %+ %2 + str_ %+ %2: + db %1, 0 + db %3 + + xt_ %+ %2 : dq i_docol +%endmacro + +%macro colon 2 +colon %1, %2, 0 +%endmacro + +%macro rpush 1 + sub rstack, 8 + mov qword [rstack], %1 +%endmacro + +%macro rpop 1 + mov %1, qword [rstack] + add rstack, 8 +%endmacro + + +%macro const 2 +%defstr %%__cnst_str %1 +native %%__cnst_str, %1 + mov rax, %2 + push rax + jmp next +%endmacro + + +%macro branch 1 +dq xt_branch +dq %1 +%endmacro + +%macro branch0 1 +dq xt_branch0 +dq %1 +%endmacro + diff --git a/forthress/part_2/obj/forthress.o b/forthress/part_2/obj/forthress.o new file mode 100644 index 0000000..d6abc98 Binary files /dev/null and b/forthress/part_2/obj/forthress.o differ diff --git a/forthress/part_2/obj/util.o b/forthress/part_2/obj/util.o new file mode 100644 index 0000000..71e1a2b Binary files /dev/null and b/forthress/part_2/obj/util.o differ diff --git a/start b/forthress/part_2/start old mode 100755 new mode 100644 similarity index 100% rename from start rename to forthress/part_2/start diff --git a/forthress/part_2/stdlib.frt b/forthress/part_2/stdlib.frt new file mode 100644 index 0000000..da13208 --- /dev/null +++ b/forthress/part_2/stdlib.frt @@ -0,0 +1,4 @@ +: ' inbuf dup word drop find ; +: rot >r swap r> swap ; +: -rot swap >r swap r> ; +: over >r dup r> swap ; diff --git a/forthress/part_2/util.asm b/forthress/part_2/util.asm new file mode 100644 index 0000000..048a75f --- /dev/null +++ b/forthress/part_2/util.asm @@ -0,0 +1,248 @@ +global string_length +global print_newline +global print_char +global print_string +global print_uint +global print_int +global parse_int +global parse_uint +global string_equals +global read_char +global read_word +global string_copy +global in_fd +global find_word +global cfa +global print_error +global exit + +extern last_word + +section .data +in_fd: dq 0 + +section .text +string_length: + xor rax, rax +.loop: + cmp byte [rdi+rax], 0 + je .end + inc rax + jmp .loop +.end: + ret + +print_newline: + mov rdi, 10 +print_char: + push rdi + mov rdi, rsp + call print_string + pop rdi + ret + +print_string: + push rdi + call string_length + pop rsi + mov rdx, rax + mov rax, 1 + mov rdi, 1 + syscall + ret + +print_uint: + mov rax, rdi + mov rdi, rsp + push 0 + sub rsp, 16 + + dec rdi + mov r8, 10 +.loop: + xor rdx, rdx + div r8 + or dl, 0x30 + dec rdi + mov [rdi], dl + test rax, rax + jnz .loop + + call print_string + + add rsp, 24 + ret + +print_int: + test rdi, rdi + jns print_uint + push rdi + mov rdi, '-' + call print_char + pop rdi + neg rdi + jmp print_uint + +; returns rax: number, rdx : length +parse_int: + mov al, byte [rdi] + cmp al, '-' + je .signed + jmp parse_uint +.signed: + inc rdi + call parse_uint + neg rax + test rdx, rdx + jz .error + + inc rdx + ret + + .error: + xor rax, rax + ret + +; returns rax: number, rdx : length +parse_uint: + mov r8, 10 + xor rax, rax + xor rcx, rcx +.loop: + movzx r9, byte [rdi + rcx] + cmp r9b, '0' + jb .end + cmp r9b, '9' + ja .end + xor rdx, rdx + mul r8 + and r9b, 0x0f + add rax, r9 + inc rcx + jmp .loop + .end: + mov rdx, rcx + ret + +string_equals: + mov al, byte [rdi] + cmp al, byte [rsi] + jne .no + inc rdi + inc rsi + test al, al + jnz string_equals + mov rax, 1 + ret + .no: + xor rax, rax + ret + +read_char: + push 0 + xor rax, rax + mov rdi, [in_fd] + mov rsi, rsp + mov rdx, 1 + syscall + pop rax + ret + +section .text + +read_word: + push r14 + xor r14, r14 + + .A: + push rdi + call read_char + pop rdi + cmp al, ' ' + je .A + cmp al, 10 + je .A + cmp al, 13 + je .A + cmp al, 9 + je .A + test al, al + jz .C + + .B: + mov byte [rdi + r14], al + inc r14 + + push rdi + call read_char + pop rdi + cmp al, ' ' + je .C + cmp al, 10 + je .C + cmp al, 13 + je .C + cmp al, 9 + je .C + test al, al + jz .C + cmp r14, 254 + je .C + + jmp .B + + .C: + mov byte [rdi + r14], 0 + mov rax, rdi + + mov rdx, r14 + pop r14 + ret + +string_copy: + mov dl, byte[rdi] + mov byte[rsi], dl + inc rdi + inc rsi + test dl, dl + jnz string_copy + ret + +find_word: + mov r8, last_word + + .loop: + test r8, r8 + jz .not_found + lea rsi, [r8 + 8] + push rdi + push rsi + call string_equals + pop rsi + pop rdi + test rax, rax + jnz .found + mov r8, [r8] + jmp .loop + + .found: + mov rax, r8 + ret + + .not_found: + xor rax, rax + ret + +cfa: + add rdi, 8 + call string_length + add rax, rdi + add rax, 2 + ret + + + +exit: + xor rdi, rdi + mov rax, 60 + syscall diff --git a/forthress/part_2/util.inc b/forthress/part_2/util.inc new file mode 100644 index 0000000..c6757db --- /dev/null +++ b/forthress/part_2/util.inc @@ -0,0 +1,21 @@ +%ifndef _UTIL_ +%define _UTIL_ + +extern string_length +extern print_newline +extern print_char +extern print_string +extern print_uint +extern print_int +extern parse_int +extern parse_uint +extern string_equals +extern read_char +extern read_word +extern string_copy +extern in_fd +extern find_word +extern print_error +extern cfa +extern exit +%endif diff --git a/forthress/part_2/words.inc b/forthress/part_2/words.inc new file mode 100644 index 0000000..c060491 --- /dev/null +++ b/forthress/part_2/words.inc @@ -0,0 +1,371 @@ +;Block of constants + const inbuf, current_word + const mem, user_mem + const state, state + const here, [here] + const last_word, last_word + +;Colon block +native "docol", docol + rpush pc + add w, 8 + mov pc, w + jmp next + +native "exit", exit + rpop pc + jmp next + +native "lit", lit + push qword [pc] + add pc, 8 + jmp next + +native "branch", branch, is_branch + mov pc, [pc] + jmp next + +native "0branch", branch0, is_branch + pop rax + test rax, rax + jz i_branch + add pc, 8 + jmp next + +native ",", comma + mov rax, [here] + pop qword [rax] + add qword [here], 8 + jmp next + +native "create", create + mov rdx, [last_word] + mov rsi, [here] + mov [rsi], rdx + mov [last_word], rsi + add rsi, 8 + mov byte [rsi], 0 + pop rdi + push rsi + call string_copy + mov rdi, qword [rsp] + call string_length + pop rsi + add rsi, rax + inc rsi + pop rax + mov [rsi], al + inc rsi + mov [here], rsi + jmp next + +colon ":", colon +.restart: + dq xt_inbuf, xt_word + branch0 .restart + dq xt_lit, 0, xt_inbuf, xt_create + dq xt_lit, 1, xt_state, xt_put_int + dq xt_lit, i_docol, xt_comma + dq xt_exit + +colon ";", semicolon, 1 + dq xt_lit, 0, xt_state, xt_put_int + dq xt_lit, xt_exit, xt_comma + dq xt_exit + +; utils block + +native "find", find + pop rdi + call find_word + push rax + jmp next + native "cfa", cfa_ + pop rdi + call cfa + push rax + jmp next + +native "syscall", syscall + pop r9 + pop r8 + pop r10 + pop rdx + pop rsi + pop rdi + pop rax + syscall + push rax + push rdx + jmp next + +native "bye", bye + mov rax, 60 + syscall + +stack_underflow: + mov rdi, msg_stack_underflow + call print_string + jmp next + +;basics block + +; (ab - ba) +native "swap", swap + pop rax + pop rcx + push rax + push rcx + jmp next + +; (a - aa) +native "dup", dup + pop rax + push rax + push rax + jmp next + +; drop top of stack +native "drop", drop + cmp rsp, [stack_head] + jge stack_underflow + pop rax + jmp next + +; arifmetics block + +;(xy - [x + y]) +native "+", plus + pop rax + add [rsp], rax + jmp next + +;(xy - [x - y]) +native "-", min + pop rax + sub [rsp], rax + jmp next + +;(xy - [x * y]) +native "*", mult + pop rax + pop rdx + imul rax, r8 + push rax + jmp next + +;(xy - [x / y]) +native "/", div + pop rax + pop r8 + mov rdx, 0 + idiv r8 + push rax + jmp next + +;(yx - [x mod y]) +native "%", mod + pop rcx + pop rax + cqo + idiv rcx + push rdx + jmp next + +;(xy - [x < y]) +native "<", less + pop rax + pop rcx + cmp rcx, rax + setl al + movzx rax, al + push rax + jmp next + +;logic block + +;(a - a') a'= 0 if a!= 0 a'= 1 if a==0 +native "not", not + pop rax + test rax, rax + je .yes + push 0 + jmp next + .yes: push 1 + jmp next + +; (ab - c) c=1 if a==b c=0 if a!=b +native "=", equals + pop rax + pop rcx + cmp rax, rcx + sete al + movzx rax, al + push rax + jmp next + +;logical and +native "land", land + pop rax + pop rdx + test rax, rax + jz .no + push rdx + jmp next +.no: + push rax + jmp next + +;logical or +native "lor", lor + pop rax + pop rdx + test rax, rax + jnz .yes + push rdx + jmp next +.yes: + push rax + jmp next + +;bitwice block + +;bitwice and +native "and", and + pop rax + and [rsp], rax + jmp next + +;bitwice or +native "or", or + pop rax + or [rsp], rax + jmp next + +;return stack operations + +; Push from return stack into data stack +native "r>", push_r + rpop rax + push rax + jmp next + +; Pop from data stack into return stack +native ">r", pop_r + pop rax + rpush rax + jmp next + +; Non-destructive copy from the top of return stack to the top of data stack +native "r@", copy_rs + mov rax, [rstack] + push rax + jmp next + +;Memory operations + +;(val addr --) Store value by address +native "!", put_int + pop rax + pop rdx + mov [rax], rdx + jmp next + +;(char addr --) Store one byte by address +native "c!", put_char + pop rax + pop rdx + mov [rax], dl + jmp next + +;(addr -- value) Fetch value from memory +native "@", get_int + pop rax + mov rax, [rax] + push rax + jmp next + +;(addr -- char) Read one byte starting at addr +native "c@", get_char + pop rax + movzx rax, byte [rax] + push rax + jmp next + +;Input-Output + +;Print top of stack +native ".", dot + cmp rsp, [stack_head] + jge stack_underflow + pop rdi + call print_int + jmp next + +;Print stack +native ".S", print_stack + mov rax, rsp + .loop: + cmp rax, [stack_head] + jge next + mov rdi, [rax] + push rax + call print_int + call print_newline + pop rax + add rax, 8 + jmp .loop + +; (str -- len ) Accepts a null-terminated string, calculates its length. +native "count", count + pop rdi + call string_length + push rax + jmp next + +; ( str cnt -- ) Prints a certain amount of characters from string. +native "printc", printc + mov rax, 1 + mov rdi, 1 + pop rsi + pop rdx + syscall + jmp next + +;( c -- ) Outputs a single character to stdout +native "emit", emit + pop rdi + call print_char + jmp next + + ; ( addr -- len ) Reads word from stdin and stores it starting at address addr. +native "word", word + pop rdi + call read_word + push rdx + jmp next + +;( str -- len num ) Parses an integer from string +native "number", number + call read_word + mov rax, rdi + call parse_int + push rax + jmp next + + ;( addr -- ) Prints a null-terminated string. +native "prints", prints + pop rdi + call print_string + jmp next + + + + + + + + + + + diff --git a/recursion.frt b/forthress/recursion.frt similarity index 100% rename from recursion.frt rename to forthress/recursion.frt diff --git a/runtime-meta.frt b/forthress/runtime-meta.frt similarity index 100% rename from runtime-meta.frt rename to forthress/runtime-meta.frt diff --git a/src/forthress.asm b/forthress/src/forthress.asm similarity index 100% rename from src/forthress.asm rename to forthress/src/forthress.asm diff --git a/src/macro.inc b/forthress/src/macro.inc similarity index 100% rename from src/macro.inc rename to forthress/src/macro.inc diff --git a/src/util.asm b/forthress/src/util.asm similarity index 100% rename from src/util.asm rename to forthress/src/util.asm diff --git a/src/util.inc b/forthress/src/util.inc similarity index 100% rename from src/util.inc rename to forthress/src/util.inc diff --git a/src/words.inc b/forthress/src/words.inc similarity index 91% rename from src/words.inc rename to forthress/src/words.inc index a542869..433c4e0 100644 --- a/src/words.inc +++ b/forthress/src/words.inc @@ -382,58 +382,6 @@ native "syscall", syscall push rdx jmp next -%ifdef NATIVE_CALLS - -extern dlsym -native "p_dlsym", p_dlsym - push dlsym - jmp next - - -; Experimental feature: native call -; The stack should hold these values, in this order -; ( function* rdi rsi rdx rcx r8 r9 rax xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7 ) -; After that, the stack will hold these values: -; ( rax rdx xmm0 xmm1 ) -; This way you can call everything even functions with variable arguments count. -; Notice, that you can pass additional integer/pointer arguments on stack, as -; Forthress data stack corresponds to the hardware stack! -native "ncall", ncall - pop rax, - movq xmm7, rax - pop rax - movq xmm6, rax - pop rax - movq xmm5, rax - pop rax - movq xmm4, rax - pop rax - movq xmm3, rax - pop rax - movq xmm2, rax - pop rax - movq xmm1, rax - pop rax - movq xmm0, rax - pop rax - pop r9 - pop r8 - pop rcx - pop rdx - pop rsi - pop rdi - add rsp, 8 - call [rsp-8] - push rax - push rdx - movq rcx, xmm0 - push rcx - movq rcx, xmm1 - push rcx - jmp next - -%endif - ; Jump to a location. Location is an absolute address ; Branch is a compile-only word. native "branch", branch diff --git a/forthress/start b/forthress/start new file mode 100644 index 0000000..4295819 --- /dev/null +++ b/forthress/start @@ -0,0 +1 @@ +cat stdlib.frt - | ./bin/forthress diff --git a/stdlib.frt b/forthress/stdlib.frt similarity index 81% rename from stdlib.frt rename to forthress/stdlib.frt index b465da3..76595d3 100644 --- a/stdlib.frt +++ b/forthress/stdlib.frt @@ -1,15 +1,6 @@ -: IMMEDIATE last_word @ cfa 1 - dup c@ 1 or swap c! ; +: > < not ; -: rot >r swap r> swap ; -: -rot swap >r swap r> ; - -: over >r dup r> swap ; -: 2dup over over ; - -: <> = not ; -: <= 2dup < -rot = lor ; -: > <= not ; -: >= < not ; +: IMMEDIATE last_word @ cfa 1 - dup @ 1 or swap c! ; : cell% 8 ; @@ -17,8 +8,6 @@ : KB 1024 * ; : MB KB KB ; -: allot dp @ swap over + dp ! ; - : begin here ; IMMEDIATE : again ' branch , , ; IMMEDIATE @@ -30,52 +19,14 @@ : repeat here ; IMMEDIATE : until ' 0branch , , ; IMMEDIATE - -: for - ' swap , - ' >r , - ' >r , -here ' r> , - ' r> , - ' 2dup , - ' >r , - ' >r , - ' < , - ' 0branch , -here 0 , - swap ; IMMEDIATE - -: endfor - ' r> , - ' lit , 1 , - ' + , - ' >r , - ' branch , - , here swap ! - ' r> , - ' drop , - ' r> , - ' drop , - -; IMMEDIATE +: for ' >r , here ' dup , ' r@ , ' > , ' 0branch , here 0 , swap ; IMMEDIATE +: endfor ' r> , ' lit , 1 , ' + , ' >r , ' branch , , here swap ! ' r> , ; IMMEDIATE : do ' swap , ' >r , ' >r , here ; IMMEDIATE -: loop - ' r> , - ' lit , 1 , - ' + , - ' dup , - ' r@ , - ' < , - ' not , - ' swap , - ' >r , - ' 0branch , , - ' r> , - ' drop , - ' r> , - ' drop , +: loop ' r> , ' lit , 1 , ' + , ' dup , ' r@ , ' < , ' not , ' swap , ' >r , ' 0branch , , +' r> , ' drop , +' r> , ' drop , ; IMMEDIATE @@ -92,7 +43,12 @@ here 0 , ( Now we can define comments :) +( a b c -- b c a ) +: rot >r swap r> swap ; +: -rot swap >r swap r> ; +: over >r dup r> swap ; +: 2dup over over ; : 2drop drop drop ; : 2over >r >r dup r> swap r> swap ; : case 0 ; IMMEDIATE @@ -100,6 +56,10 @@ here 0 , : endof ' else execute ; IMMEDIATE : endcase ' drop , dup if repeat ' then execute dup not until drop then ; IMMEDIATE +: <> = not ; +: <= 2dup < -rot = lor ; +: >= 2dup > -rot = lor ; + ( num from to -- 1/0) : in-range rot swap over >= -rot <= land ; @@ -122,7 +82,7 @@ then ; : cr 10 emit ; -: QUOTE 34 ; +: QUOTE 34 emit ; : _" compiling if @@ -169,20 +129,6 @@ readce dup 34 = if drop 1 else emit 0 then until then ; IMMEDIATE -: g" - dp @ - - repeat - readce dup 34 = if - drop 0 1 allot c! 1 - else 1 allot c! 0 then - until - - compiling if - ' lit , , - then ; IMMEDIATE - - : ." ' " execute compiling if ' prints , then ; IMMEDIATE : read-digit readc dup .' 0 .' 9 in-range if .' 0 - else drop -1 then ; @@ -261,6 +207,8 @@ compnumber r@ file-close r> drop ; +( cells - addr ) +: allot dp @ swap over + dp ! ; : global inbuf word drop 0 inbuf create ' docol @ , ' lit , cell% allot , ' exit , ; : constant inbuf word drop 0 inbuf create ' docol @ , ' lit , , ' exit , ; @@ -271,8 +219,6 @@ compnumber : end-struct constant ; include diagnostics.frt -include doc-engine.frt -include documentation.frt 16 MB ( heap size ) include heap.frt @@ -296,7 +242,3 @@ include managed-string.frt ." Forthress -- a tiny Forth from scratch > (c) Igor Zhirkov 2017-2018 " cr -include fib.frt - -include native.frt - diff --git a/string.frt b/forthress/string.frt similarity index 91% rename from string.frt rename to forthress/string.frt index cc54f5b..b12a0c2 100644 --- a/string.frt +++ b/forthress/string.frt @@ -54,7 +54,7 @@ ( string in heap ) : h" compiling not if 0 - repeat readc dup QUOTE = if + repeat readc dup .' " = if ( " syntax highlight fix ) drop dup dp @ + 0 swap c! 1 + heap-alloc dup dp @ string-copy 1 @@ -65,7 +65,7 @@ then until else -' " execute ' string-new , +' " execute ' dup , ' string-new , then ; IMMEDIATE