KevinMidboe/linguist
1
0
Fork 0
mirror of https://github.com/KevinMidboe/linguist.git synced 2025-10-29 09:40:21 +00:00
Code Issues Packages Projects Releases Wiki Activity

More Forth samples.

Browse Source
This commit is contained in:
Baptiste Fontaine
2013-02-18 00:21:46 +01:00
parent 2431f2120c
commit 055743f886
5 changed files with 642 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

79
samples/Forth/KataDiversion.fth Normal file
View 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
View 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
View 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
View 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
View 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> ;