/samples/Forth/core-ext.fth
Forth | 136 lines | 84 code | 51 blank | 1 comment | 4 complexity | 5fc21cdc65221129b6e08455db9e7d1d MD5 | raw file
- \ -*- forth -*- Copyright 2004, 2013 Lars Brinkhoff
- \ Kernel: #tib
- \ TODO: .r
- : .( ( "<string><paren>" -- )
- [char] ) parse type ; immediate
- : 0<> ( n -- flag ) 0 <> ;
- : 0> ( n -- flag ) 0 > ;
- \ Kernel: 2>r
- : 2r> ( -- x1 x2 ) ( R: x1 x2 -- ) r> r> r> rot >r swap ;
- : 2r@ ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 ) 2r> 2dup 2>r ;
- : :noname align here 0 c, 15 allot lastxt dup @ , !
- [ ' enter >code @ ] literal , 0 , ] lastxt @ ;
- \ Kernel: <>
- \ : ?do ( n1 n2 -- ) ( R: -- loop-sys ) ( C: -- do-sys )
- \ here postpone 2>r unresolved branch here ;
- : again ( -- ) ( C: dest -- )
- postpone branch , ; immediate
- : string+ ( caddr -- addr )
- count + aligned ;
- : (c") ( -- caddr ) ( R: ret1 -- ret2 )
- r> dup string+ >r ;
- : c" ( "<string><quote>" -- caddr )
- postpone (c") [char] " parse dup c, string, ; immediate
- : case ( -- ) ( C: -- case-sys )
- 0 ;
- : compile, ( xt -- )
- , ;
- \ TODO: convert
- : endcase ( x -- ) ( C: case-sys -- )
- 0 do postpone then loop
- postpone drop ;
- : endof ( -- ) ( C: case-sys1 of-sys -- case-sys2 )
- postpone else swap 1+ ;
- \ TODO: erase
- \ TODO: expect
- : false ( -- 0 )
- 0 ;
- : hex ( -- )
- 16 base ! ;
- \ TODO: marker
- \ Kernel: nip
- : of ( x x -- | x y -- x ) ( C: -- of-sys )
- postpone over postpone = postpone if postpone drop ;
- \ Kernel: pad
- \ Kernel: parse
- : pick ( xn ... x0 n -- xn ... x0 xn )
- 2 + cells 'SP @ + @ ;
- : query ( -- )
- tib ''source ! #tib ''#source ! 0 'source-id !
- refill drop ;
- \ Kernel: refill
- \ Kernel: restore-input
- \ TODO: roll ( xn xn-1 ... x0 n -- xn-1 ... x0 xn ) ;
- \ Kernel: save-input
- \ Kernel: source-id
- \ TODO: span
- \ Kernel: tib
- : to ( x "word" -- )
- ' >body , ;
- : true ( -- -1 )
- -1 ;
- : tuck ( x y -- y x y )
- swap over ;
- \ TODO: u.r
- : u> ( x y -- flag )
- 2dup u< if 2drop false else <> then ;
- \ TODO: unused
- : value ( x "word" -- )
- create ,
- does> ( -- x )
- @ ;
- : within over - >r - r> u< ;
- \ TODO: [compile]
- \ Kernel: \
- \ ----------------------------------------------------------------------
- ( Forth2012 core extension words. )
- \ TODO: action-of
- \ TODO: buffer:
- : defer create ['] abort , does> @ execute ;
- : defer! ( xt2 xt1 -- ) >body ! ;
- : defer@ ( xt1 -- xt2 ) >body @ ;
- \ TODO: holds
- : is ( xt "word" -- ) ' defer! ;
- \ TODO: parse-name
- \ TODO: s\"