mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 09:40:21 +00:00
More Forth samples.
This commit is contained in:
Baptiste Fontaine
79
samples/Forth/KataDiversion.fth
Normal file
79
samples/Forth/KataDiversion.fth
Normal file
@@ -0,0 +1,79 @@
|
||||
\ KataDiversion in Forth
|
||||
|
||||
\ -- utils
|
||||
|
||||
\ empty the stack
|
||||
: EMPTY
|
||||
DEPTH 0 <> IF BEGIN
|
||||
DROP DEPTH 0 =
|
||||
UNTIL
|
||||
THEN ;
|
||||
|
||||
\ power
|
||||
: ** ( n1 n2 -- n1_pow_n2 ) 1 SWAP ?DUP IF 0 DO OVER * LOOP THEN NIP ;
|
||||
|
||||
\ compute the highest power of 2 below N.
|
||||
\ e.g. : 31 -> 16, 4 -> 4
|
||||
: MAXPOW2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Maxpow2 need a positive value."
|
||||
ELSE DUP 1 = IF 1
|
||||
ELSE
|
||||
1 >R
|
||||
BEGIN ( n |R: i=1)
|
||||
DUP DUP I - 2 *
|
||||
( n n 2*[n-i])
|
||||
R> 2 * >R ( … |R: i*2)
|
||||
> ( n n>2*[n-i] )
|
||||
UNTIL
|
||||
R> 2 /
|
||||
THEN
|
||||
THEN NIP ;
|
||||
|
||||
\ -- kata
|
||||
|
||||
\ test if the given N has two adjacent 1 bits
|
||||
\ e.g. : 11 -> 1011 -> -1
|
||||
\ 9 -> 1001 -> 0
|
||||
: ?NOT-TWO-ADJACENT-1-BITS ( n -- bool )
|
||||
\ the word uses the following algorithm :
|
||||
\ (stack|return stack)
|
||||
\ ( A N | X ) A: 0, X: N LOG2
|
||||
\ loop: if N-X > 0 then A++ else A=0 ; X /= 2
|
||||
\ return 0 if A=2
|
||||
\ if X=1 end loop and return -1
|
||||
0 SWAP DUP DUP 0 <> IF
|
||||
MAXPOW2 >R
|
||||
BEGIN
|
||||
DUP I - 0 >= IF
|
||||
SWAP DUP 1 = IF 1+ SWAP
|
||||
ELSE DROP 1 SWAP I -
|
||||
THEN
|
||||
ELSE NIP 0 SWAP
|
||||
THEN
|
||||
OVER
|
||||
2 =
|
||||
I 1 = OR
|
||||
R> 2 / >R
|
||||
UNTIL
|
||||
R> 2DROP
|
||||
2 <>
|
||||
ELSE 2DROP INVERT
|
||||
THEN ;
|
||||
|
||||
\ return the maximum number which can be made with N (given number) bits
|
||||
: MAX-NB ( n -- m ) DUP 1 < IF DROP 0 ( 0 )
|
||||
ELSE
|
||||
DUP IF DUP 2 SWAP ** NIP 1 - ( 2**n - 1 )
|
||||
THEN
|
||||
THEN ;
|
||||
|
||||
|
||||
\ return the number of numbers which can be made with N (given number) bits
|
||||
\ or less, and which have not two adjacent 1 bits.
|
||||
\ see http://www.codekata.com/2007/01/code_kata_fifte.html
|
||||
: HOW-MANY-NB-NOT-TWO-ADJACENT-1-BITS ( n -- m )
|
||||
DUP 1 < IF DUP 0
|
||||
ELSE
|
||||
0 SWAP
|
||||
MAX-NB 1 + 0 DO I ?NOT-TWO-ADJACENT-1-BITS - LOOP
|
||||
THEN ;
|
||||
|
||||
42
samples/Forth/block.fth
Normal file
42
samples/Forth/block.fth
Normal file
@@ -0,0 +1,42 @@
|
||||
( Block words. )
|
||||
|
||||
variable blk
|
||||
variable current-block
|
||||
|
||||
: block ( n -- addr )
|
||||
current-block ! 0 ;
|
||||
|
||||
: buffer ( n -- addr )
|
||||
current-block ! 0 ;
|
||||
|
||||
\ evaluate (extended semantics)
|
||||
\ flush ( -- )
|
||||
|
||||
: load ( ... n -- ... )
|
||||
dup current-block !
|
||||
blk !
|
||||
save-input
|
||||
0 >in !
|
||||
blk @ block ''source ! 1024 ''#source !
|
||||
( interpret )
|
||||
restore-input ;
|
||||
|
||||
\ save-buffers ( -- )
|
||||
\ update ( -- )
|
||||
|
||||
( Block extension words. )
|
||||
|
||||
\ empty-buffers ( -- )
|
||||
|
||||
variable scr
|
||||
|
||||
: list ( n -- )
|
||||
dup scr !
|
||||
dup current-block !
|
||||
block 1024 bounds do i @ emit loop ;
|
||||
|
||||
\ refill (extended semantics)
|
||||
|
||||
: thru ( x y -- ) +1 swap do i load loop ;
|
||||
|
||||
\ \ (extended semantics)
|
||||
136
samples/Forth/core-ext.fth
Normal file
136
samples/Forth/core-ext.fth
Normal file
@@ -0,0 +1,136 @@
|
||||
\ -*- 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\"
|
||||
252
samples/Forth/core.fth
Normal file
252
samples/Forth/core.fth
Normal file
@@ -0,0 +1,252 @@
|
||||
: immediate lastxt @ dup c@ negate swap c! ;
|
||||
|
||||
: \ source nip >in ! ; immediate \ Copyright 2004, 2012 Lars Brinkhoff
|
||||
|
||||
: char \ ( "word" -- char )
|
||||
bl-word here 1+ c@ ;
|
||||
|
||||
: ahead here 0 , ;
|
||||
|
||||
: resolve here swap ! ;
|
||||
|
||||
: ' bl-word here find 0branch [ ahead ] exit [ resolve ] 0 ;
|
||||
|
||||
: postpone-nonimmediate [ ' literal , ' compile, ] literal , ;
|
||||
|
||||
: create dovariable_code header, reveal ;
|
||||
|
||||
create postponers
|
||||
' postpone-nonimmediate ,
|
||||
' abort ,
|
||||
' , ,
|
||||
|
||||
: word \ ( char "<chars>string<char>" -- caddr )
|
||||
drop bl-word here ;
|
||||
|
||||
: postpone \ ( C: "word" -- )
|
||||
bl word find 1+ cells postponers + @ execute ; immediate
|
||||
|
||||
: unresolved \ ( C: "word" -- orig )
|
||||
postpone postpone postpone ahead ; immediate
|
||||
|
||||
: chars \ ( n1 -- n2 )
|
||||
;
|
||||
|
||||
: else \ ( -- ) ( C: orig1 -- orig2 )
|
||||
unresolved branch swap resolve ; immediate
|
||||
|
||||
: if \ ( flag -- ) ( C: -- orig )
|
||||
unresolved 0branch ; immediate
|
||||
|
||||
: then \ ( -- ) ( C: orig -- )
|
||||
resolve ; immediate
|
||||
|
||||
: [char] \ ( "word" -- )
|
||||
char postpone literal ; immediate
|
||||
|
||||
: (does>) lastxt @ dodoes_code over >code ! r> swap >does ! ;
|
||||
|
||||
: does> postpone (does>) ; immediate
|
||||
|
||||
: begin \ ( -- ) ( C: -- dest )
|
||||
here ; immediate
|
||||
|
||||
: while \ ( x -- ) ( C: dest -- orig dest )
|
||||
unresolved 0branch swap ; immediate
|
||||
|
||||
: repeat \ ( -- ) ( C: orig dest -- )
|
||||
postpone branch , resolve ; immediate
|
||||
|
||||
: until \ ( x -- ) ( C: dest -- )
|
||||
postpone 0branch , ; immediate
|
||||
|
||||
: recurse lastxt @ compile, ; immediate
|
||||
|
||||
: pad \ ( -- addr )
|
||||
here 1024 + ;
|
||||
|
||||
: parse \ ( char "string<char>" -- addr n )
|
||||
pad >r begin
|
||||
source? if <source 2dup <> else 0 0 then
|
||||
while
|
||||
r@ c! r> 1+ >r
|
||||
repeat 2drop pad r> over - ;
|
||||
|
||||
: ( \ ( "string<paren>" -- )
|
||||
[ char ) ] literal parse 2drop ; immediate
|
||||
\ TODO: If necessary, refill and keep parsing.
|
||||
|
||||
: string, ( addr n -- )
|
||||
here over allot align swap cmove ;
|
||||
|
||||
: (s") ( -- addr n ) ( R: ret1 -- ret2 )
|
||||
r> dup @ swap cell+ 2dup + aligned >r swap ;
|
||||
|
||||
create squote 128 allot
|
||||
|
||||
: s" ( "string<quote>" -- addr n )
|
||||
state @ if
|
||||
postpone (s") [char] " parse dup , string,
|
||||
else
|
||||
[char] " parse >r squote r@ cmove squote r>
|
||||
then ; immediate
|
||||
|
||||
: (abort") ( ... addr n -- ) ( R: ... -- )
|
||||
cr type cr abort ;
|
||||
|
||||
: abort" ( ... x "string<quote>" -- ) ( R: ... -- )
|
||||
postpone if postpone s" postpone (abort") postpone then ; immediate
|
||||
|
||||
\ ----------------------------------------------------------------------
|
||||
|
||||
( Core words. )
|
||||
|
||||
\ TODO: #
|
||||
\ TODO: #>
|
||||
\ TODO: #s
|
||||
|
||||
: and ( x y -- x&y ) nand invert ;
|
||||
|
||||
: * 1 2>r 0 swap begin r@ while
|
||||
r> r> swap 2dup dup + 2>r and if swap over + swap then dup +
|
||||
repeat r> r> 2drop drop ;
|
||||
|
||||
\ TODO: */mod
|
||||
|
||||
: +loop ( -- ) ( C: nest-sys -- )
|
||||
postpone (+loop) postpone 0branch , postpone unloop ; immediate
|
||||
|
||||
: space bl emit ;
|
||||
|
||||
: ?.- dup 0 < if [char] - emit negate then ;
|
||||
|
||||
: digit [char] 0 + emit ;
|
||||
|
||||
: (.) base @ /mod ?dup if recurse then digit ;
|
||||
|
||||
: ." ( "string<quote>" -- ) postpone s" postpone type ; immediate
|
||||
|
||||
: . ( x -- ) ?.- (.) space ;
|
||||
|
||||
: postpone-number ( caddr -- )
|
||||
0 0 rot count >number dup 0= if
|
||||
2drop nip
|
||||
postpone (literal) postpone (literal) postpone ,
|
||||
postpone literal postpone ,
|
||||
else
|
||||
." Undefined: " type cr abort
|
||||
then ;
|
||||
|
||||
' postpone-number postponers cell+ !
|
||||
|
||||
: / ( x y -- x/y ) /mod nip ;
|
||||
|
||||
: 0< ( n -- flag ) 0 < ;
|
||||
|
||||
: 1- ( n -- n-1 ) -1 + ;
|
||||
|
||||
: 2! ( x1 x2 addr -- ) swap over ! cell+ ! ;
|
||||
|
||||
: 2* ( n -- 2n ) dup + ;
|
||||
|
||||
\ Kernel: 2/
|
||||
|
||||
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;
|
||||
|
||||
\ Kernel: 2drop
|
||||
\ Kernel: 2dup
|
||||
|
||||
\ TODO: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
|
||||
\ 3 pick 3 pick ;
|
||||
|
||||
\ TODO: 2swap
|
||||
|
||||
\ TODO: <#
|
||||
|
||||
: abs ( n -- |n| )
|
||||
dup 0< if negate then ;
|
||||
|
||||
\ TODO: accept
|
||||
|
||||
: c, ( n -- )
|
||||
here c! 1 chars allot ;
|
||||
|
||||
: char+ ( n1 -- n2 )
|
||||
1+ ;
|
||||
|
||||
: constant create , does> @ ;
|
||||
|
||||
: decimal ( -- )
|
||||
10 base ! ;
|
||||
|
||||
: depth ( -- n )
|
||||
data_stack 100 cells + 'SP @ - /cell / 2 - ;
|
||||
|
||||
: do ( n1 n2 -- ) ( R: -- loop-sys ) ( C: -- do-sys )
|
||||
postpone 2>r here ; immediate
|
||||
|
||||
\ TODO: environment?
|
||||
\ TODO: evaluate
|
||||
\ TODO: fill
|
||||
\ TODO: fm/mod )
|
||||
\ TODO: hold
|
||||
|
||||
: j ( -- x1 ) ( R: x1 x2 x3 -- x1 x2 x3 )
|
||||
'RP @ 3 cells + @ ;
|
||||
|
||||
\ TODO: leave
|
||||
|
||||
: loop ( -- ) ( C: nest-sys -- )
|
||||
postpone 1 postpone (+loop)
|
||||
postpone 0branch ,
|
||||
postpone unloop ; immediate
|
||||
|
||||
: lshift begin ?dup while 1- swap dup + swap repeat ;
|
||||
|
||||
: rshift 1 begin over while dup + swap 1- swap repeat nip
|
||||
2>r 0 1 begin r@ while
|
||||
r> r> 2dup swap dup + 2>r and if swap over + swap then dup +
|
||||
repeat r> r> 2drop drop ;
|
||||
|
||||
: max ( x y -- max[x,y] )
|
||||
2dup > if drop else nip then ;
|
||||
|
||||
\ Kernel: min
|
||||
\ TODO: mod
|
||||
\ TODO: move
|
||||
|
||||
: (quit) ( R: ... -- )
|
||||
return_stack 100 cells + 'RP !
|
||||
0 'source-id ! tib ''source ! #tib ''#source !
|
||||
postpone [
|
||||
begin
|
||||
refill
|
||||
while
|
||||
interpret state @ 0= if ." ok" cr then
|
||||
repeat
|
||||
bye ;
|
||||
|
||||
' (quit) ' quit >body cell+ !
|
||||
|
||||
\ TODO: s>d
|
||||
\ TODO: sign
|
||||
\ TODO: sm/rem
|
||||
|
||||
: spaces ( n -- )
|
||||
0 do space loop ;
|
||||
|
||||
\ TODO: u.
|
||||
|
||||
: signbit ( -- n ) -1 1 rshift invert ;
|
||||
|
||||
: xor ( x y -- x^y ) 2dup nand >r r@ nand swap r> nand nand ;
|
||||
|
||||
: u< ( x y -- flag ) signbit xor swap signbit xor > ;
|
||||
|
||||
\ TODO: um/mod
|
||||
|
||||
: variable ( "word" -- )
|
||||
create /cell allot ;
|
||||
|
||||
: ['] \ ( C: "word" -- )
|
||||
' postpone literal ; immediate
|
||||
133
samples/Forth/tools.fth
Normal file
133
samples/Forth/tools.fth
Normal file
@@ -0,0 +1,133 @@
|
||||
\ -*- forth -*- Copyright 2004, 2013 Lars Brinkhoff
|
||||
|
||||
( Tools words. )
|
||||
|
||||
: .s ( -- )
|
||||
[char] < emit depth (.) ." > "
|
||||
'SP @ >r r@ depth 1- cells +
|
||||
begin
|
||||
dup r@ <>
|
||||
while
|
||||
dup @ .
|
||||
/cell -
|
||||
repeat r> 2drop ;
|
||||
|
||||
: ? @ . ;
|
||||
|
||||
: c? c@ . ;
|
||||
|
||||
: dump bounds do i ? /cell +loop cr ;
|
||||
|
||||
: cdump bounds do i c? loop cr ;
|
||||
|
||||
: again postpone branch , ; immediate
|
||||
|
||||
: see-find ( caddr -- end xt )
|
||||
>r here lastxt @
|
||||
begin
|
||||
dup 0= abort" Undefined word"
|
||||
dup r@ word= if r> drop exit then
|
||||
nip dup >nextxt
|
||||
again ;
|
||||
|
||||
: cabs ( char -- |char| ) dup 127 > if 256 swap - then ;
|
||||
|
||||
: xt. ( xt -- )
|
||||
( >name ) count cabs type ;
|
||||
|
||||
: xt? ( xt -- flag )
|
||||
>r lastxt @ begin
|
||||
?dup
|
||||
while
|
||||
dup r@ = if r> 2drop -1 exit then
|
||||
>nextxt
|
||||
repeat r> drop 0 ;
|
||||
|
||||
: disassemble ( x -- )
|
||||
dup xt? if
|
||||
( >name ) count
|
||||
dup 127 > if ." postpone " then
|
||||
cabs type
|
||||
else
|
||||
.
|
||||
then ;
|
||||
|
||||
: .addr dup . ;
|
||||
|
||||
: see-line ( addr -- )
|
||||
cr ." ( " .addr ." ) " @ disassemble ;
|
||||
|
||||
: see-word ( end xt -- )
|
||||
>r ." : " r@ xt.
|
||||
r@ >body do i see-line /cell +loop
|
||||
." ;" r> c@ 127 > if ." immediate" then ;
|
||||
|
||||
: see bl word see-find see-word cr ;
|
||||
|
||||
: #body bl word see-find >body - ;
|
||||
|
||||
: type-word ( end xt -- flag )
|
||||
xt. space drop 0 ;
|
||||
|
||||
: traverse-dictionary ( in.. xt -- out.. )
|
||||
\ xt execution: ( in.. end xt2 -- in.. 0 | in.. end xt2 -- out.. true )
|
||||
>r here lastxt @ begin
|
||||
?dup
|
||||
while
|
||||
r> 2dup >r >r execute
|
||||
if r> r> 2drop exit then
|
||||
r> dup >nextxt
|
||||
repeat r> 2drop ;
|
||||
|
||||
: words ( -- )
|
||||
['] type-word traverse-dictionary cr ;
|
||||
|
||||
\ ----------------------------------------------------------------------
|
||||
|
||||
( Tools extension words. )
|
||||
|
||||
\ ;code
|
||||
|
||||
\ assembler
|
||||
|
||||
\ in kernel: bye
|
||||
|
||||
\ code
|
||||
|
||||
\ cs-pick
|
||||
|
||||
\ cs-roll
|
||||
|
||||
\ editor
|
||||
|
||||
: forget ' dup >nextxt lastxt ! 'here ! reveal ;
|
||||
|
||||
\ Kernel: state
|
||||
|
||||
\ [else]
|
||||
|
||||
\ [if]
|
||||
|
||||
\ [then]
|
||||
|
||||
\ ----------------------------------------------------------------------
|
||||
|
||||
( Forth2012 tools extension words. )
|
||||
|
||||
\ TODO: n>r
|
||||
|
||||
\ TODO: nr>
|
||||
|
||||
\ TODO: synonym
|
||||
|
||||
: [undefined] bl-word find nip 0= ; immediate
|
||||
|
||||
: [defined] postpone [undefined] invert ; immediate
|
||||
|
||||
\ ----------------------------------------------------------------------
|
||||
|
||||
: @+ ( addr -- addr+/cell x ) dup cell+ swap @ ;
|
||||
|
||||
: !+ ( x addr -- addr+/cell ) tuck ! cell+ ;
|
||||
|
||||
: -rot swap >r swap r> ;
|
||||
Reference in New Issue
Block a user