Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: e1580c9736
Fetching contributors…

Cannot retrieve contributors at this time

393 lines (286 sloc) 7.94 kB
token ; make
postpone lit 1 c,
postpone state
postpone !
postpone last
postpone @
postpone lit 1 c,
postpone +
postpone last
postpone !
postpone lit
0 c,
postpone here
postpone @
postpone lit
0 c,
postpone +
postpone c!
postpone lit
2 c,
postpone here
postpone @
postpone lit
1 c,
postpone +
postpone c!
immediate
last @ 1 + last !
token (:) make
postpone make
postpone lit
0 c,
postpone state
postpone !
;
token : (:) token (:) ;
: [ 1 state ! ; immediate
: ] 0 state ! ;
: here@ here @ ;
: literal 3 c, c, ;
: rliteral 4 c, , ;
: sliteral swap rliteral literal ;
: allot there @ + there ! ;
: rcell 4 ;
: rcells rcell * ;
: rcells+ rcells + ;
: (create) make there @ rliteral postpone ; ;
: create token (create) ;
: variable : there @ rliteral postpone ; rcell allot ;
: const : rliteral postpone ; ;
: bconst : literal postpone ; ;
create table 16 32 * allot
variable #section
7 #section !
: 2dup swap dup rot dup rot swap ;
: 1+ 1 + ;
: 1- 1 - ;
: 0= 0 = ;
: cr 10 emit ;
: space 32 emit ;
: begin here@ ; immediate
: again postpone branch here@ - c, immediate ;
: until postpone branch0 here@ - c, ; immediate
: if postpone branch0 here@ 0 c, ; immediate
: then dup here@ swap - swap c! ; immediate
: else >r postpone branch here@ 0 c, r> postpone then ; immediate
: | begin key 10 = until ; immediate
| moved from strings.4k
: 2drop drop drop ;
: over swap dup >r swap r> ;
: 2dup over over ;
: while postpone branch0 here@ 0 c, ; immediate
: repeat postpone branch swap here@ - c, dup here@ swap - swap c! ; immediate
: ?dup dup if dup then ;
: case 0 ; immediate
: of postpone over postpone = postpone if postpone drop ; immediate
: endof postpone else ; immediate
: endcase' begin ?dup while postpone then repeat ; immediate
: endcase postpone drop postpone endcase' ; immediate
| Taking into account prefix word
| : ; 0 here @ c! -2 here @ 1+ c! last @ 1+ last !
| last @ 253 = if 256 last ! then postpone [ ; immediate
| please note this changes MUST BE HERE! (for some reason i forgot hehehe)
| : (create) make there @ rliteral postpone ; ;
| : create token (create) ;
| : variable : there @ rliteral postpone ; rcell allot ;
| : const : rliteral postpone ; ;
: c: key state @ 0 = if literal then ; immediate
: ( 1
begin
c: ) key dup rot = if swap 1- dup 0= if drop drop ;; then swap then
c: ( = if 1+ then
again ; immediate
: (* begin key c: * = if key c: ) = if ;; then then again ; immediate
(*
a multi
line
comment
*)
| comparison words
: <> = invert ;
: 0<> 0= invert ;
: <= > invert ;
: >= < invert ;
: +! swap >r dup @ r> + swap ! ;
: -! swap >r dup @ r> - swap ! ;
: 1+! 1 swap +! ;
: 1-! 1 swap -! ;
: data: here there @ here@ there ! swap ! ;
: data; data: ;
| output words
| to verbose but will make optimisations later
| by default we will use byte cells, as it is meant to be 4kb tool
: cell 1 ;
: cells cell * ;
| ref cells
: r ( -- r ) postpone r> postpone dup postpone >r ; immediate
: rdrop ( -- r: v -- ) postpone r> postpone drop ; immediate
| strings
create #str
1000 allot
: parse ( delimiter -- str c ) [ there @ rliteral ] c! here @ >r #str here !
begin key dup [ there @ rliteral ]
c@ = if drop #str here @ #str - 0 c, r> here ! ;; then
c, again
;
create parse-buffer
1000 allot
: >with-here postpone here@ postpone >r postpone here postpone ! ; immediate
: with-here> postpone r> postpone here postpone ! ; immediate
: parse2 ( delimiter -- str c )
parse-buffer >with-here
>r 0 begin key dup r = 0= while c, 1+ repeat rdrop drop
with-here> parse-buffer swap
;
| : parse ( delimiter -- str c )
| >r begin key r = if rdrop ;; then
: \" c: " parse ;
| "
| inlines a counted list of bytes to there
: inline ( str c -- str c )
here @ >r there @ here ! here @ + >r
begin r here @ = if drop there @ r> there @ - here @ there ! r> here ! ;; then
dup c@ c, 1+ again
;
| do loops
: do
postpone swap
postpone >r
postpone >r
postpone begin
; immediate
: leave postpone r> postpone r> postpone drop postpone drop ; immediate
: loop
postpone r>
postpone dup
postpone 1+
postpone r
postpone swap
postpone >r
postpone =
postpone until
postpone r>
postpone r>
postpone drop
postpone drop
; immediate
: i postpone r ; immediate
: j postpone r>
postpone r>
postpone r>
postpone dup
postpone >r
postpone swap
postpone >r
postpone swap
postpone >r
; immediate
: type ( str c -- ) 1- dup 0 >= if 0 do dup i + c@ emit loop then drop ;
: inc ( adr -- ) dup @ 1+ swap ! ;
: dec ( adr -- ) dup @ 1- swap ! ;
| exit current word if TOS is zero
: 0; ( n -- ) postpone = postpone if
postpone ;; postpone then
; immediate
: next-set ( char-adr char-adr -- ) 1+ swap 1+ swap ;
: ch@ ( char-adr char-adr -- t/f ) c@ swap c@ ;
variable flag
| compare two zero terminated strings, the strings are assumed to be
| of the same size (no size checking )
: compare ( str str -- t/f ) -1 flag !
begin
2dup ch@ 2dup = invert if 0 flag ! then
and 0 = if 2drop flag @ ;; then next-set
again
;
| compare two counted strings ( so with size checking )
: str= ( str c str c -- t/f ) >r swap r> = if compare ;; then 2drop 0 ;
| pimped ", it now compiles the string to there @compile time
: " \" state @ 0 = if inline there @ dup 0 swap c! 1+ there !
sliteral then
; immediate
(*
: " \" inline there @ dup 0 swap c! 1+ there !
state @ 0 = if sliteral then ; immediate
*)
: ." ( -- ) postpone "
state @ 0 = if postpone type ;; then type
; immediate
: ccall: : postpone ccall c, postpone ; ;
0 ccall: dlopen
1 ccall: dlsym
: >cstr drop ;
: lib >cstr $2 swap dlopen ;
: sym >cstr swap dlsym ;
variable #ithere
4 #ithere !
: add-handle ( handle stackfix -- )
| ." index: " #ithere @ 2 / . cr
| over 0 = if ." ERROR: handle is 0" cr 2drop ;; then
| over ." handle: " . ." stackfix: " dup . cr
| ." index: " #ithere @ 2 / . cr
| over 0 = if ." ERROR: handle is 0" cr 2drop ;; then over ." handle: " . cr
ithere @ 1 #ithere @ + rcells+ !
ithere @ #ithere @ rcells+ !
#ithere @ 2 + #ithere !
;
: include" \" include ;
| Hmmmm this does inteerupt compiling
| "
| : require" \" over over find -1 = if over over make postpone ; include ;; then ." File " type ." already provided." cr ;
: require" \" over over find -1 = if over over make postpone ; include ;; then ;
| count the given zero-terminated string
: count ( str -- c ) 0 >r
begin dup c@ 0 = if drop r> ;; then 1+ r> 1+ >r again
;
: words ( -- )
last @ 1-
begin
dup 32 * ntab @ + dup count type space
dup 0 = if cr drop ;; then
1-
again
;
: inc ( ptr1 ptr2 c -- ptr1 ptr2 ) dup rot + swap rot + swap ;
| Not 100% correct (but works with overlapping blocks )
| @spec, what does this thing do???
| @phon, copy blocks of memory even if they overlap.
: cmove> ( src dst c -- )
>r 2dup <
if
2dup swap r + <
if
r 1- inc
begin r> dup 0 = if drop r> drop drop drop ;; then 1- >r 2dup swap c@ swap c! -1 inc again
then
then
begin r> dup 0 = if drop r> drop drop drop ;; then 1- >r 2dup swap c@ swap c! 1 inc again
;
: copy ( src c dst -- )
there @ >r there ! inline 2drop r> there !
;
| "
: there: ( -- ) here there @ here @ there ! swap ! ;
: ;there ( -- ) there here @ there @ here ! swap ! ;
: mark ( -- ) here @ there @
" *marker*" make rliteral rliteral postpone ;
; immediate
: forget ( -- )
" *marker*" find
dup -1 <> if dup last ! execute there ! here !
-1 here @ c! -1 -2 here @ 1+ c! ;; then drop
;
| dump
variable savebase
base @ savebase !
16 const b16
10 const b10
: base! base @ savebase ! base ! ;
: hex b16 base! ;
: dec b10 base! ;
: [hex] hex ; immediate
: [dec] dec ; immediate
: switch-base savebase @ base ! ;
: [switch-base] res-base ; immediate
| : . . space ;
Jump to Line
Something went wrong with that request. Please try again.