From 1b30051ee29fbf6a0ddf989a1faac2481d601bd9 Mon Sep 17 00:00:00 2001
From: Justin Bedo <cu@cua0.org>
Date: Mon, 19 Nov 2012 10:11:44 +1100
Subject: Import of untracked forth codebase.

---
 forth.f | 110 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 110 insertions(+)
 create mode 100644 forth.f

(limited to 'forth.f')

diff --git a/forth.f b/forth.f
new file mode 100644
index 0000000..e8e8044
--- /dev/null
+++ b/forth.f
@@ -0,0 +1,110 @@
+: -+ - + ;
+: / /mod nip ;
+: if immediate ' 0branch ,, here 0 , ;
+: then immediate ] here swap ! ;
+
+: find-) key 41 != if find-) ; then ;
+: ( immediate find-) ;
+( now there's parenthetical comments :)
+
+: find-cr key 10 != if find-cr ; then ;
+: \ immediate find-cr ;
+\ and now line comments
+
+: '@ @ ; \ A tickable @
+: variable here 0 , word create ' lit ,, , exit ;
+: constant here swap , word create ' lit ,, , ' '@ ,, exit ;
+: array word create ' lit ,, here 0 , exit here swap ! ;
+
+\ Some stuff for printing/compiling number strings
+: cr 10 emit ;
+: space 32 emit ;
+: tab 9 emit ;
+
+\ strings
+: read-until-" key dup 34 = if 2drop ; then
+	c, 1 over +! read-until-" ;
+: read-str
+	' lit ,, here 0 , \ ptr
+	' lit ,, here 0 , \ cnt
+	' branch ,, here 0 , \ branch
+	rot here swap ! \ ptr set
+	swap
+	read-until-"
+	0 c, \ Null terminate strings for syscalls
+	here swap !
+;
+: s" immediate read-str ;
+: print dup 0<= if 2drop ; then
+	1- swap dup c@ emit 1+ swap print ;
+: ." immediate
+	read-str
+	' print ,,
+;
+
+\ Exit back to linux
+: bye 0 1 syscall1 ;
+: fatal 1 1 syscall1 ;
+
+\ File IO
+0 constant OREAD
+1 constant OWRITE
+2 constant ORW
+100 constant OCREATE
+1 constant PROT_READ
+2 constant PROT_WRITE
+1 constant MAP_SHARED
+variable zero 0 zero !
+: ?error -1 = if ." file syscall error" cr fatal ; then ;
+: write 4 syscall3 dup ?error ;
+: _open 5 syscall3 dup ?error ;
+: close 6 syscall1 ?error ;
+: lseek 19 syscall3 dup ?error ;
+: truncate 92 syscall2 ?error 42 emit ;
+: open nip 0 _open ;
+: screate nip OCREATE or 420 _open ;
+: rswap <r <r swap >r >r ;
+: mmap ( path -- ptr )
+	ORW open dup dup >r fsize dup <r swap >r >r 0 swap
+	PROT_READ PROT_WRITE or MAP_SHARED <r 0 192 syscall6 dup ?error
+	swap close <r ;
+: mmap-screate ( path len -- ptr ) ( fl )
+	>r ORW screate <r
+	2dup 1- 0 lseek drop over zero 1 write drop
+	swap dup >r >r 0 swap
+	PROT_READ PROT_WRITE or MAP_SHARED <r 0 192 syscall6 dup ?error
+	<r close ;
+	
+\ String tokeniser
+variable cur
+variable len
+variable end
+array buffer 50 allot
+: ?end end @ >= ;
+: ?sep 33 < ;
+: cnt-word ( cnt ptr -- cnt )
+	dup ?end if drop ; then
+	dup c@ ?sep if drop ; then
+	swap 1+ swap 1+ cnt-word ;
+: find-first-char ( ptr -- ptr )
+	dup ?end 0= if
+		dup c@ ?sep if 1+ find-first-char ; then
+	then ;
+: tokenise ( ptr len -- ) over + end ! cur ! 0 len ! ;
+: token ( -- ptr len ) cur @ len @ + find-first-char dup cur !
+	0 over cnt-word dup len ! ;
+
+\ log math
+: lsqrt 0.5 lpow ;
+: sq dup l* ;
+
+
+\ High level operators
+variable map-fun
+variable map-stat
+: do-map dup 0<= if drop ; then
+	1- @+ map-fun @ execute !+ do-map ;
+: map ( pnf -- ) map-fun ! swap dup >a >b do-map ;
+: do-sweep dup 0<= if drop ; then
+	@+ map-stat @ map-fun @ execute !+ 1- do-sweep ;
+: sweep ( pnsf -- ) map-fun ! map-stat ! swap dup >a >b do-sweep ;
-- 
cgit v1.2.3