You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 

140 lines
3.9 KiB

: \ source >in ! drop ; immediate
: ( 41 0 parse1 drop drop ; immediate
: abort -1 throw ;
: nip ( x1 x2 -- x2 ) swap drop ;
: over ( x1 x2 -- x1 x2 x1 ) 1 pick ;
: 2drop ( dx -- ) drop drop ;
: 2dup ( dx -- dx dx ) over over ;
: literal, ( x -- ) make-literal , ;
: literal ( C: x -- ) literal, ; immediate compile-only
: branch, ( addr n -- ) make-branch , ;
: branch! ( place target -- ) over @ make-branch swap ! ;
: ['] ' literal, ; immediate compile-only
: [ 0 state ! ; immediate
: ] 1 state ! ;
: if here 0 , ; immediate compile-only
: else here -1 , >r here branch! r> ; immediate compile-only
: then here branch! ; immediate compile-only
: ?dup ( x -- 0 | x x ) dup if else drop then ;
: 0= ( n -- flag ) 0 = ;
: 0<> ( n -- flag ) 0 <> ;
: 0< ( n -- flag ) 0 < ;
: 0> ( n -- flag ) 0 > ;
: 0<= ( n -- flag ) 0 <= ;
: 0>= ( n -- flag ) 0 >= ;
: 0<=> ( n1 -- n2 ) 0 <=> ;
: nop ( -- ) ;
: 1+ ( n1 -- n2 ) 1 + ;
: 1- ( n1 -- n2 ) 1 - ;
: +! ( n addr -- ) dup >r @ + r> ! ;
synonym chars nop
synonym cells nop
synonym char+ 1+
synonym cell+ 1+
synonym c@ @
synonym c! !
synonym c, ,
: begin here ; immediate compile-only
: until 0 branch, ; immediate compile-only
: while here 0 , swap ; immediate compile-only
: repeat -1 branch, here branch! ; immediate compile-only
: variable ( -- ) create 1 cells allot ;
: constant ( x -- ) create , does> @ ;
32 constant bl
1024 allocate drop constant pad
: count ( addr -- addr n ) dup @ swap 1+ swap ;
: parse ( c -- addr n ) 0 parse1 ;
: parse-name ( -- addr n ) bl 1 parse1 ;
: find ( addr -- addr 0 | xt 1 | xt -1 )
dup count find1 if
nip dup immediate? if 1 else -1 then
else 0 then ;
: char bl parse drop @ ;
: [char] char literal, ; immediate compile-only
\ Return stack: ( leave limit index ).
: unloop r> 2r> 2drop r> drop >r ;
: leave r> drop 2r> 2drop ;
: do-setup r>q >r 2>r q>r ;
: ?do-setup r>q >r 2dup = if 2drop q> drop else 2>r q>r then ;
: do-header here null , swap compile, ;
: do ['] do-setup do-header ; immediate compile-only
: ?do ['] ?do-setup do-header ; immediate compile-only
: +loop-step r>q 2r> 2dup <=> >r
rot + 2dup <=> r> <> -rot 2>r q>r ;
: +loop postpone +loop-step
dup 2 + 0 branch, postpone unloop
here make-literal swap ! ; immediate compile-only
: loop 1 literal, postpone +loop ; immediate compile-only
synonym i r@
: j 4 rpick ;
: move ( addr1 addr2 n ) 0 ?do over i + @ over i + ! loop 2drop ;
: move> ( addr1 addr2 n ) 1- -1 swap ?do over i + @ over i + ! -1 +loop 2drop ;
synonym cmove move
synonym cmove> move>
: only ( -- ) -1 set-order ;
: also ( -- ) get-order over swap 1+ set-order ;
: (wordlist) ( wid -- ) create , does>
@ >r get-order nip r> swap set-order ;
forth-wordlist (wordlist) forth
: is" ( -- addr n ) [char] " parse >r
r@ allocate drop swap over r@ move r> ;
: ic" ( -- addr ) [char] " parse >r
r@ 1+ allocate drop r@ over ! swap over 1+ r> move ;
: s" ( -- addr n ) is" literal, ; immediate compile-only
: c" ( -- addr n ) ic" literal, ; immediate compile-only
: ij" ( -- addr n ) [char] " parse jstring ;
: j" ( -- addr n ) ij" literal, ; immediate compile-only
: property@" ( obj -- obj ) postpone j"
postpone property@ ; immediate compile-only
: property!" ( obj obj -- ) postpone j"
postpone property! ; immediate compile-only
: property-delete" ( obj -- ) postpone j"
postpone property-delete ; immediate compile-only
: prop. ( obj -- obj )
begin [char] . parse dup
while jstring property@ repeat
2drop ;
: [prop]. ( obj -- obj )
begin [char] . parse dup
while jstring literal, postpone property@ repeat
2drop ; immediate compile-only
: window. ( -- obj ) window prop. ;
: [window]. ( -- obj ) window.
literal, ; immediate compile-only
: jlog ( obj -- ) 1 this [window]. console.log.. jcall drop ;
: log ( addr n -- ) jstring jlog ;
: ." ( -- ) postpone j" postpone jlog ; immediate compile-only
: .( ( -- ) [char] ) parse jstring jlog ;