aboutsummaryrefslogtreecommitdiff
path: root/amforth-6.5/examples
diff options
context:
space:
mode:
Diffstat (limited to 'amforth-6.5/examples')
-rw-r--r--amforth-6.5/examples/ascii.frt13
-rw-r--r--amforth-6.5/examples/co.frt36
-rw-r--r--amforth-6.5/examples/date-time.frt29
-rw-r--r--amforth-6.5/examples/easter.frt112
-rw-r--r--amforth-6.5/examples/fib.frt12
-rw-r--r--amforth-6.5/examples/forward-declarations-test.frt12
-rw-r--r--amforth-6.5/examples/forward-declarations.frt23
-rw-r--r--amforth-6.5/examples/fsm.frt67
-rw-r--r--amforth-6.5/examples/i2c-compass.frt55
-rw-r--r--amforth-6.5/examples/life.frt178
-rw-r--r--amforth-6.5/examples/literacy.frt49
-rw-r--r--amforth-6.5/examples/local.frt64
-rw-r--r--amforth-6.5/examples/many.frt13
-rw-r--r--amforth-6.5/examples/parsed-to.frt22
-rw-r--r--amforth-6.5/examples/queens.frt54
-rw-r--r--amforth-6.5/examples/readme.txt37
-rw-r--r--amforth-6.5/examples/rec-char.frt12
-rw-r--r--amforth-6.5/examples/rec-double-paren.frt73
-rw-r--r--amforth-6.5/examples/rec-name.frt18
-rw-r--r--amforth-6.5/examples/run-hayes.frt26
-rw-r--r--amforth-6.5/examples/scope.frt21
-rw-r--r--amforth-6.5/examples/sierpinsi.frt26
-rw-r--r--amforth-6.5/examples/sieve.frt58
-rw-r--r--amforth-6.5/examples/stack.frt76
-rw-r--r--amforth-6.5/examples/string-rec.frt28
-rw-r--r--amforth-6.5/examples/time-rec.frt59
-rw-r--r--amforth-6.5/examples/value-variations.frt65
27 files changed, 1238 insertions, 0 deletions
diff --git a/amforth-6.5/examples/ascii.frt b/amforth-6.5/examples/ascii.frt
new file mode 100644
index 0000000..ab09ad6
--- /dev/null
+++ b/amforth-6.5/examples/ascii.frt
@@ -0,0 +1,13 @@
+\ print a ascii table
+: .ascii
+base @
+$7f $20 do
+ i emit
+ decimal ." , dec: " i .
+ hex ." , hex: " i .
+ 8 base ! ." , oct: " i .
+ 2 base ! ." , bin: " i .
+ cr
+loop
+base !
+;
diff --git a/amforth-6.5/examples/co.frt b/amforth-6.5/examples/co.frt
new file mode 100644
index 0000000..0351ff9
--- /dev/null
+++ b/amforth-6.5/examples/co.frt
@@ -0,0 +1,36 @@
+\ coroutines
+
+: co r> r> swap >r >r ;
+
+: tokyo
+ ." Here Tokyo over" cr co
+ ." What gives? over" cr co
+ ." Yes, more? over" cr co
+ ." over and out" cr
+;
+
+: amsterdam
+ tokyo
+ ." here Amsterdam over" cr co
+ ." has it arrived over" cr co
+ ." no. over and out" cr
+;
+
+\ amsterdam
+
+\ generate a list of numbers, one by one
+: producer ( n -- n' n' ) begin 1+ dup co again ;
+: consumer
+ \ setup producer
+ 0 producer \ returns with a new number
+ \ now starts a ping-pong via co calls
+ \ every call to co *here* will give a new number
+ \ which has to be consumed.
+ begin dup . 10 < while co repeat
+ \ stop producer and clean up data
+ r> drop drop
+;
+\ output:
+\ > consumer
+\ 0 1 2 3 4 5 6 7 8 9 10 ok
+\ >
diff --git a/amforth-6.5/examples/date-time.frt b/amforth-6.5/examples/date-time.frt
new file mode 100644
index 0000000..13e5d25
--- /dev/null
+++ b/amforth-6.5/examples/date-time.frt
@@ -0,0 +1,29 @@
+
+\ create task space
+$20 $20 0 task: t:date&time
+
+variable seconds
+\ runs every second
+: job-date&time
+ 1 seconds +!
+ \ more code for minute/hour/day...
+ 0 \ flag for an endless loop
+;
+
+\ set up the task
+: setup-date&time
+ t:date&time task-init \ create TCB in RAM
+ 0 seconds ! \ more code for minutes etc
+ t:date&time tcb>tid activate
+ \ code from here is executed as task, later on
+ ['] job-date&time every-second
+;
+
+\ setup and start the task "date/time"
+: turnkey-date&time
+ onlytask \ set up multitasker
+ 6 timer0.init timer0.start \ 16 MHz quartz
+ \ insert task into task list
+ setup-date&time t:date&time tcb>tid alsotask
+ multi \ start multitasking
+;
diff --git a/amforth-6.5/examples/easter.frt b/amforth-6.5/examples/easter.frt
new file mode 100644
index 0000000..f742d31
--- /dev/null
+++ b/amforth-6.5/examples/easter.frt
@@ -0,0 +1,112 @@
+
+\ Date of Easter According to Knuth
+\ Donald E. Knuth, _The Art of Computer Programming_, 1.3.2 Exercise
+\ 14-15.
+\ [Commentary by Knuth, Forth by Wil Baden. This is not well-suited
+\ for Forth, but there's no advantage in purifying it.]
+\ The following algorithm, due to the Neapolitan astronomer Aloysius
+\ Lilius and the German Jesuit mathematician Christopher Clavius in
+\ the late 16th century, is used by most Western churches to
+\ determine the date of Easter Sunday for any year after 1582.
+
+\ Counters.
+
+\ Y
+\ Year.
+\ G
+\ Golden number.
+\ C
+\ Century.
+\ X
+\ Century leap year adjustment.
+\ Z
+\ Moon's orbit adjustment.
+\ D
+\ Sunday date.
+\ E
+\ Epact.
+\ N
+\ Day of month.
+
+variable easter.y \ Year
+variable easter.g \ Golden number
+variable easter.c \ Century
+variable easter.x \ Century leap year adjustment
+variable easter.z \ Moon's orbit adjustment
+variable easter.d \ Sunday date
+variable easter.e \ Epact
+variable easter.n \ Day of month
+
+\ EASTER ( yyyyy -- dd mm yyyyy )
+\ Compute date of Easter for year _yyyyy_.
+
+: easter ( yyyyy -- dd mm yyyyy )
+ easter.y ! ( )
+ \ E1. Golden number.
+ \ _G_ is the so-called "golden number" of the year in the
+ \ 19-year Metonic cycle.
+
+ easter.y @ 19 mod 1+ easter.g !
+
+ \ E2. Century.
+ \ When _Y_ is not a multiple of 100, _C_ is the century number;
+ \ for example, 1984 is in the twentieth century.
+
+ easter.y @ 100 / 1+ easter.c !
+
+ \ E3. Corrections.
+ \ Here _X_ is the number of years, such as 1900, in which leap
+ \ year was dropped in order to keep in step with the sun; _Z_ is
+ \ a special correction designed to synchronize Easter with the
+ \ moon's orbit.
+
+ easter.c @ 3 4 */ 12 - easter.x !
+ easter.c @ 8 * 5 + 25 / 5 - easter.z !
+
+ \ E4. Find Sunday.
+ \ March ((-_D_) mod 7) actually will be a Sunday.
+
+ easter.y @ 5 4 */ easter.x @ - 10 - easter.d !
+
+ \ E5. Epact.
+ \ This number _E_ is the _epact_, which specifies when a full
+ \ moon occurs.
+
+ easter.g @ 11 * 20 + easter.z @ + easter.x @ - 30 mod
+ dup 0< if 30 + then
+ easter.e !
+ easter.e @ 25 = dup if drop easter.g @ 11 > then
+ dup 0= if drop easter.e @ 24 = then
+ if 1 easter.e +! then
+
+ \ E6. Find full moon.
+ \ Easter is supposedly the first Sunday following the first full
+ \ moon that occurs on or after March 21. Actually perturbations
+ \ in the moon's orbit do not make this strictly true, but we are
+ \ concerned here with the "calendar moon" rather than the actual
+ \ moon. The _N_th of March is a calendar full moon.
+
+ 44 easter.e @ - easter.n !
+ easter.n @ 21 < if 30 easter.n +! then
+
+ \ E7. Advance to Sunday.
+
+ easter.n @ 7 +
+ easter.d @ easter.n @ + 7 mod -
+ easter.n !
+
+ \ E8. Get month.
+
+ easter.n @ 31 > if
+ easter.n @ 31 - 4 easter.y @
+ else
+ easter.n @ 3 easter.y @
+ then ;
+
+\ .EASTER ( yyyyy -- )
+\ Display date of Easter for year _yyyyy_.
+
+: .easter ( yyyyy -- )
+ easter . 4 = if ." April" else ." March" then 3 .R ;
+
+\\ ************************* End of Easter *************************
diff --git a/amforth-6.5/examples/fib.frt b/amforth-6.5/examples/fib.frt
new file mode 100644
index 0000000..3eaab4a
--- /dev/null
+++ b/amforth-6.5/examples/fib.frt
@@ -0,0 +1,12 @@
+( fibonacci number )
+: fib
+ dup 2 > if
+ dup 1- recurse swap 1- 1- recurse + exit
+ then
+ drop 1
+;
+
+: fib-iter 0 1 rot 0 ?do over + swap loop drop ;
+
+: dfib-iter >r 0 s>d 1 s>d r> 0 ?do 2over d+ 2swap loop 2drop .s ;
+
diff --git a/amforth-6.5/examples/forward-declarations-test.frt b/amforth-6.5/examples/forward-declarations-test.frt
new file mode 100644
index 0000000..b44ce94
--- /dev/null
+++ b/amforth-6.5/examples/forward-declarations-test.frt
@@ -0,0 +1,12 @@
+forward: foo
+
+: bar foo ;
+: baz foo ;
+
+bar \ should cause an error: foo not bound, or (simpler) silently crash
+
+: foo ." I'm foo the first" ;
+bar \ should execute the does> part of forward: for foo
+: foo ." I'm the second foo" ;
+baz \ uses the new definition of foo!
+
diff --git a/amforth-6.5/examples/forward-declarations.frt b/amforth-6.5/examples/forward-declarations.frt
new file mode 100644
index 0000000..274edf4
--- /dev/null
+++ b/amforth-6.5/examples/forward-declarations.frt
@@ -0,0 +1,23 @@
+: forward:
+ dp
+ create
+ ,
+ \ save more information?
+ does>
+ \ get the current name and
+ \ lookup the dictionary. get the
+ \ XT and replace the dictionary entry in the
+ \ *caller* with it. After that execute it too
+ \ next code is executed only once if successful
+ dup 1- swap @i here iplace here count ( copy to temporary ram)
+ find-name if \ unless some wordlist voodoo is in place...
+ swap over = abort" found only forward declaration."
+ dup r@ 1- !i execute
+ else
+ \ can only happen if search wordlist has changed
+ true abort" unresolved forward declaration"
+ then
+;
+
+
+
diff --git a/amforth-6.5/examples/fsm.frt b/amforth-6.5/examples/fsm.frt
new file mode 100644
index 0000000..94af976
--- /dev/null
+++ b/amforth-6.5/examples/fsm.frt
@@ -0,0 +1,67 @@
+\ FSM routines, from a paper presented by J . Noble-----
+\ ---------------------------------------------------------
+\ you can find the paper at http://www.forth.org/literature/noble.html
+\ The fsm: word has been modified to correctly increment addresses by
+\ word, instead of byte. and to also use the i@ dictionary fetch word.
+\ Ver 1.1 fsm: now implements "The best FSM so far" (see paper). State
+\ is now a heap variable with it's address in the dictionary of the fsm.
+\ Written by Bernard Mentink
+
+marker _fsm_
+
+hex
+
+\ dummy nop word for readability
+: wide ;
+
+\ perform word that executes vector
+: perform
+ @i execute ;
+
+\ Get 2 cells from dictionary space
+: 2@i
+ dup 1+ @i swap @i ;
+
+\ comment if you have this word.
+: tuck swap over ;
+
+\ Allocate a RAM variable on the data space, init with x, and return RAM address
+: >ram ( x -- addr ) here 1 cells allot tuck ! ;
+
+
+\ This word creates FSM transition tables
+: fsm: ( width -- )
+ create 0 >ram , , ] \ ram addr of state stored in dict,also width.
+ does> ( col# adr -- )
+ dup dup >r 2@i @ * 2* + ( -- col#+width*state )
+ swap 2* 1+ 1+ + ( -- offset-to-action)
+ dup >r ( -- offset-to-action)
+ perform ( ? )
+ r> 1+ ( -- offset-to-update)
+ perform ( -- state')
+ r> @i ! ; \ update state
+
+
+\ ......... some test code ..............
+\ un-comment the code lines to test state changes dependant on input supplied
+\ e.g 2 test_fsm, 0 test_fsm etc
+\ If you want the address of the state variable associated with your state
+\ machine, create the following word : mystate ['] test_fsm 1+ i@ ;
+
+\ : one ." one " ;
+\ : two ." two " ;
+\ : three ." three " ;
+\ : four ." four " ;
+\ : nop ." nop " ;
+
+\ 0 constant >0
+\ 1 constant >1
+\ 2 constant >2
+
+\ a test state-machine table
+\ 4 wide fsm: test_fsm
+\ input: | 0 | 1 | 2 | 3 |
+\ state: ---------------------------------------------
+\ ( 0 ) nop >0 one >1 one >1 two >2
+\ ( 1 ) four >1 one >1 nop >1 two >2
+\ ( 2 ) nop >2 two >2 nop >2 nop >2 ;
diff --git a/amforth-6.5/examples/i2c-compass.frt b/amforth-6.5/examples/i2c-compass.frt
new file mode 100644
index 0000000..651af14
--- /dev/null
+++ b/amforth-6.5/examples/i2c-compass.frt
@@ -0,0 +1,55 @@
+\
+\ compass module mmc2120 (memsic)
+\ hwid is always $30
+\ provides:
+\
+\ i2c.compass.get ( -- status X Y)
+\ X and Y are around 2000 (raw data)
+\ status is 0 if no error occured
+
+\ further calculation?
+
+$30 constant i2c.compass
+
+\ internal commands
+: i2c.compass.setcoil
+ i2c.compass i2c.begin
+ 0 i2c.tx
+ %00000010 i2c.tx \ set coil
+ i2c.end
+;
+: i2c.compass.resetcoil
+ i2c.compass i2c.begin
+ 0 i2c.tx
+ %00000100 i2c.tx \ reset coil
+ i2c.end
+;
+
+: i2c.compass.measure
+ i2c.compass i2c.begin
+ 0 i2c.tx
+ %00000001 i2c.tx \ start measurement
+ i2c.end
+;
+
+: i2c.compass.fetchdata ( -- status x y )
+ i2c.compass i2c.begin
+ 0 i2c.tx
+ i2c.start \ rep-start
+ i2c.compass i2c.rd i2c.tx
+ 4 0 do i2c.rx loop i2c.rxn
+ i2c.end
+ ( -- status msb-x lsb-x msb-y lsb-y)
+ swap >< or $fff and >r \ Y
+ swap >< or $fff and r> \ X
+;
+
+\ get the raw data from the module
+\ the numbers for X/Y are usually around 2000.
+\ status is 0 if everything is ok
+: i2c.compass.get ( -- status x y )
+ i2c.compass.resetcoil 1ms
+ i2c.compass.setcoil 5 ms
+ i2c.compass.measure 5 ms
+ i2c.compass.fetchdata
+;
diff --git a/amforth-6.5/examples/life.frt b/amforth-6.5/examples/life.frt
new file mode 100644
index 0000000..a8543c1
--- /dev/null
+++ b/amforth-6.5/examples/life.frt
@@ -0,0 +1,178 @@
+\ Conway's Game of Life, or Occam's Razor Dulled
+
+\ The original ANS Forth version by Leo Wong (see bottom)
+\ has been modified slightly to allow it to run under
+\ kForth. Also, delays have been changed from 1000 ms to
+\ 100 ms for faster update --- K. Myneni, 12-26-2001
+\
+marker Genesis
+
+\ needs portpone.frt, marker.frt, 2x.frt, ans.frt
+\ and finally vt100.frt already loaded
+
+decimal
+
+\ ANS Forth this life is remains and
+1 chars constant /char
+: c+! ( char c-addr -- ) dup >r c@ + r> c! ;
+
+\ the universal pattern; optimum is 25x80, but that
+\ requires memory. The 10x20 screen works on an Atmega16
+
+&10 constant How-Deep
+&20 constant How-Wide
+
+\ nothing beyound this line should be changed
+
+How-Wide How-Deep * 1- \ 1- prevents scrolling on my screen
+ constant Homes
+
+\ world wrap
+: World
+ variable ( -- ) Homes chars allot
+ does> ( u -- c-addr ) @i swap Homes + Homes mod chars + ;
+
+World old
+World new
+
+\ biostatistics
+
+\ begin hexadecimal numbering
+hex \ hex xy : x holds life , y holds neighbors count
+
+10 constant Alive \ 0y = not alive
+
+\ Conway's rules:
+\ a life depends on the number of its next-door neighbors
+
+\ it dies if it has fewer than 2 neighbors
+: Lonely ( char -- flag ) 12 < ;
+
+\ it dies if it has more than 3 neighbors
+: Crowded ( char -- flag ) 13 > ;
+
+: -Sustaining ( char -- flag )
+ dup Lonely swap Crowded or ;
+
+\ it is born if it has exactly 3 neighbors
+: Quickening ( char -- flag )
+ 03 = ;
+
+\ back to decimal
+decimal
+
+\ compass points
+: N ( i -- j ) How-Wide - ;
+: S ( i -- j ) How-Wide + ;
+: E ( i -- j ) 1+ ;
+: W ( i -- j ) 1- ;
+
+\ census
+: Home+! ( -1|1 i -- ) >r Alive * r> new c+! ;
+
+: Neighbors+! ( -1|0|1 i -- )
+ 2dup N W new c+! 2dup N new c+! 2dup N E new c+!
+ 2dup W new c+! ( i ) 2dup E new c+!
+ 2dup S W new c+! 2dup S new c+! S E new c+! ;
+
+: Bureau-of-Vital-Statistics ( -1|1 i -- )
+ 2dup Home+! Neighbors+! ;
+
+\ mortal coils
+char ? constant Soul
+ bl constant Body
+
+\ at home
+: Home ( char i -- ) How-Wide /mod at-xy emit ;
+
+\ changes, changes
+: Is-Born ( i -- )
+ Soul over Home
+ 1 swap Bureau-of-Vital-Statistics ;
+: Dies ( i -- )
+ Body over Home
+ -1 swap Bureau-of-Vital-Statistics ;
+
+\ the one and the many
+: One ( c-addr -- i )
+ 0 old - /char / ;
+: Everything ( -- )
+ 0 old Homes
+ begin dup
+ while over c@ dup Alive and
+ if -Sustaining if over One Dies then
+ else Quickening if over One Is-Born then then
+ 1 /string
+ repeat 2drop
+ How-Wide 1- How-Deep 1- at-xy ;
+
+\ in the beginning
+: Void ( -- )
+ 0 old Homes blank ;
+
+\ spirit
+: Voice ( -- c-addr u )
+ page
+ ." Say: " 0 new dup Homes accept ;
+
+\ subtlety
+: Serpent ( -- )
+ 0 2 at-xy ." Press a key for knowledge." key drop
+ 0 2 at-xy ." Press space to re-start, Esc to escape life." ;
+
+\ the primal state
+: Innocence ( -- )
+ Homes 0
+ do i new c@ Alive / i Neighbors+! loop ;
+
+\ children become parents
+: Passes ( -- ) 0 new 0 old Homes cmove ;
+
+\ a garden
+: Paradise ( c-addr u -- )
+ >r How-Deep How-Wide * How-Deep 2 mod 0= How-Wide and -
+ r@ - 2/ old
+ r> cmove
+ 0 old Homes 0
+ do count bl <>
+ dup if Soul i Home then
+ Alive and i new c!
+ loop drop
+ Serpent
+ Innocence Passes ;
+
+: Creation ( -- ) Void Voice Paradise ;
+
+\ the human element
+
+( 1000) 100 constant Ideas
+: Dreams ( -- ) Ideas ms ;
+
+( 1000) 100 constant Images
+: Meditation ( -- ) Images ms ;
+
+\ free will
+: Action ( -- char )
+ key? dup
+ if drop key
+ dup bl = if Creation then
+ then ;
+
+\ environmental dependence
+27 constant Escape
+
+\ history
+: Goes-On ( -- )
+ begin Everything Passes
+ Dreams Action Meditation
+ Escape = until ;
+
+\ a vision
+: Life ( -- ) Creation Goes-On ;
+
+
+\ run the word Life and enjoy
+
+\ Copyright 1995 Leo Wong
+\ hello@albany.net
+\ http://www.albany.net/~hello/
diff --git a/amforth-6.5/examples/literacy.frt b/amforth-6.5/examples/literacy.frt
new file mode 100644
index 0000000..b9b0bd9
--- /dev/null
+++ b/amforth-6.5/examples/literacy.frt
@@ -0,0 +1,49 @@
+\ from Newsgroups: comp.lang.forth
+\ Date: Sun, 28 Dec 2014 14:12:44 -0800 (PST)
+\ Message-ID: <fdfa0f77-57f9-4ea6-b5bc-32d5651aabef@googlegroups.com>
+\ Subject: String literacy
+\ From: Julian Fondren <julian....@gmail.com>
+\ Adapted to most recent recognizer RFD
+
+
+\ Also, notice how I intend code by two spaces? That makes it very
+\ clear what's code and what's me talking about code, without the
+\ reader having to keep switching between two files, say. It also
+\ allows me to tie documentation and source together in such a way
+\ that one will seldom be supplied without the other. You could
+\ even organize your code into 'blocks', with corresponding 'shadow
+\ blocks' ... well, once again, let's just do it:
+
+\ This is the entire contents of literate.fs:
+
+ ' noop ' noop ' noop recognizer: r:noop
+ : literacy-recognizer ( c-addr u -- r:noop | r:fail )
+ 2drop source s" " string-prefix? if r:fail else 0 parse 2drop r:noop then ;
+
+ \ place it at the top of the recognizer stack
+ forth-recognizers get-recognizers
+ 1+ ' literacy-recognizer swap
+ forth-recognizers set-recognizers
+
+And the entire rest of my post will be the contents of a file
+named hello.fs, which makes use of it:
+
+--- hello.fs begins next line ---
+ require literate.fs
+
+Having required literate.fs, the rest of this file is commentary unless
+intended by two spaces.
+
+For example, Forth will pass over the following:
+
+: hello ( -- ) cr ." Hello!" ;
+
+But will compile and execute these indented statements:
+
+ : goodbye ( -- )
+ cr ." Good bye." ;
+
+ goodbye bye bye bye
+
+(This behavior is also seen interactively.)
+
diff --git a/amforth-6.5/examples/local.frt b/amforth-6.5/examples/local.frt
new file mode 100644
index 0000000..71564a2
--- /dev/null
+++ b/amforth-6.5/examples/local.frt
@@ -0,0 +1,64 @@
+\ trivial local
+
+\ there is exactly one local called X
+\ it is not initialized upon entry
+\ it works like a local should do:
+\ get the content by calling X, assign
+\ a new value with TO
+
+\ separate local stack
+\ max. call depth 10
+
+\ "2" means "1 cells", if portability is a concern
+
+#10 cells constant l-size
+\ the local stack pointer and the stack itself
+l-size cell+ buffer: lsp
+
+\ initialize l-stackpointer, call it
+\ in e.g. turnkey prior to use!
+: l-init lsp l-size + lsp ! ;
+
+\ general stack access, unsued
+: l@ lsp @ @ ;
+: l! lsp @ ! ;
+: l-free 2 lsp +! ;
+: l-alloc -2 lsp +! ;
+: >l l! l-alloc ;
+: l> l-free l@ ;
+
+: local@ negate lsp @ + @ ;
+: local! negate lsp @ + ! ;
+
+\ define a local by its offset
+\ relative to the local stack pointer
+: local ( offset "name" -- )
+ (value) ,
+ ['] local@ ,
+ ['] local! ,
+;
+
+\ should be smarter, it should
+\ check whether X is used at all
+\ and allocate the local stack
+\ only if needed.
+: : : l-alloc ;
+: ; l-free postpone ; ; immediate
+
+\ globally define a label for the first
+\ local variable. The X is a global name
+\ but has local content. If using more,
+\ add a l-alloc/l-free pair in the : and ;
+\ definitions above.
+
+0 local X
+
+\ test cases
+\ l-init
+\ : test1 to X X . ;
+\ 1 test1
+\ -> 1
+\ : test2 1 test1 to X X . ;
+\ 2 test2
+\ -> 1 2
+\ \ No newline at end of file
diff --git a/amforth-6.5/examples/many.frt b/amforth-6.5/examples/many.frt
new file mode 100644
index 0000000..c5bfc49
--- /dev/null
+++ b/amforth-6.5/examples/many.frt
@@ -0,0 +1,13 @@
+\ Rick VanNorman, clf 15. Apr 1997
+
+: many key? if key drop exit then 0 >in ! ;
+
+\ use it like
+\ > 0
+\ > dup . 1+ many
+\ 0 1 2 3 4 5 6 .....
+\
+\ this repeats the current input line until a key
+\ is hit. The repeat can, of course, cause a total
+\ desaster
+\ \ No newline at end of file
diff --git a/amforth-6.5/examples/parsed-to.frt b/amforth-6.5/examples/parsed-to.frt
new file mode 100644
index 0000000..8c06769
--- /dev/null
+++ b/amforth-6.5/examples/parsed-to.frt
@@ -0,0 +1,22 @@
+
+\ prepend -> to a value name and act like TO
+\ 42 to answer
+\ is the same as
+ \ 42 ->answer
+\ The -> should be made a synonymous to TO
+\
+\ actions
+:noname defer! ;
+:noname postpone literal postpone defer! ;
+:noname postpone 2literal ;
+recognizer: r:parsed-to
+
+: rec-parsed-to ( addr len -- addr r:parsed-to | r:fail )
+ over @ $3e2d = ( -> ) 0= if 2drop r:fail exit then
+ \ something left?
+ 2 /string dup 0= if 2drop r:fail exit then
+ \ search for the name
+ find-name 0= if r:fail exit then
+ ( -- xt )
+ r:parsed-to
+;
diff --git a/amforth-6.5/examples/queens.frt b/amforth-6.5/examples/queens.frt
new file mode 100644
index 0000000..e20b05d
--- /dev/null
+++ b/amforth-6.5/examples/queens.frt
@@ -0,0 +1,54 @@
+\ Copyright (c) 2007 the authors listed at the following URL, and/or
+\ the authors of referenced articles or incorporated external code:
+\ http://en.literateprograms.org/Eight_queens_puzzle_(Forth)?action=history&offset=20070512025943
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+\ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+\ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+\ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+\ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ Retrieved from: http://en.literateprograms.org/Eight_queens_puzzle_(Forth)?oldid=10015
+marker queen
+
+ : bits ( bits -- mask ) 1 swap lshift 1- ;
+ : lowBit ( mask -- bit ) dup negate and ;
+ : lowBit- ( mask -- mask ) dup 1- and ;
+ : third ( a b c -- a b c a ) 2 pick ;
+
+ variable solutions
+ variable nodes
+ : poss ( a b c -- a b c a&b&c ) dup 2over and and ;
+
+ : next3 ( dl dr f Qfilebit -- dl dr f dl' dr' f' )
+ invert >r
+ third r@ and 2* 1+
+ third r@ and 2/
+ third r> and ;
+
+ : try ( dl dr f -- ) \ bitmasks for unused diagonals and files
+ dup if 1 nodes +! poss
+ begin ?dup while
+ dup >r lowBit next3 recurse r> lowBit-
+ repeat
+ else ( .sol) 1 solutions +! then
+ drop drop drop ;
+
+ : queens ( n -- ) >r
+ 0 solutions ! 0 nodes !
+ -1 dup r@ bits try
+ r> . ." queens: " solutions @ u. ." solutions, " nodes @ u. ." nodes" ;
+
diff --git a/amforth-6.5/examples/readme.txt b/amforth-6.5/examples/readme.txt
new file mode 100644
index 0000000..940d913
--- /dev/null
+++ b/amforth-6.5/examples/readme.txt
@@ -0,0 +1,37 @@
+This folder contains some example codes not
+related to any application.
+
+easter.frt: calculates the date of easter. almost unmodfied version
+ of Will Baden's code
+
+fib.frt: simple benchmark. calculate a fibonacci number using
+ different algorithm.
+
+sieve.frt: not-so simple benchmark modelled after the sieve code
+ of Marcel Hendrix. Uses single bits to store the is-prim flag.
+
+run-hayes.frt: demonstrate the use of the amforth-upload.py utility
+ and the special #include syntax. The test itself is a slightly
+ modified HAYES test suite
+
+queens.frt: solves the queens problem for various size, maybe useful
+ as a benchmark.
+
+ascii.frt: prints an ascii table on screen
+
+life.frt: Conveys game of life. Its very memory intensive, the example
+ code works on an Atmega16, but a bigger one would allow larger
+ worlds.
+
+string-rec.frt: converts a " delimited string into a printable,
+ compilable and postponable text object. It replaces the s" command.
+
+sierpinski.frt: simple fractal generator. Illustrates the use of
+ the amforth-shell to include library files.
+
+co.frt: co routines aka subroutines for nonpreemtive multitasking.
+ Examples on how to use them are included.
+
+many.frt: Repeat the input line until a key is hit. Use it with care
+ since it can cause a lot of trouble. Since the input line is re-parsed
+ every time, it is much slower than a compiled word.
diff --git a/amforth-6.5/examples/rec-char.frt b/amforth-6.5/examples/rec-char.frt
new file mode 100644
index 0000000..1e7b1ac
--- /dev/null
+++ b/amforth-6.5/examples/rec-char.frt
@@ -0,0 +1,12 @@
+\ check for the 'c' syntax for single
+\ characters.
+: rec:char ( addr len -- n r:num | r:fail )
+ 3 = if \ a three character string
+ dup c@ [char] ' = if \ starts with a '
+ dup 2 + c@ [char] ' = if \ and ends with a '
+ 1+ c@ r:num exit
+ then
+ then
+ then
+ drop r:fail
+;
diff --git a/amforth-6.5/examples/rec-double-paren.frt b/amforth-6.5/examples/rec-double-paren.frt
new file mode 100644
index 0000000..254fa9e
--- /dev/null
+++ b/amforth-6.5/examples/rec-double-paren.frt
@@ -0,0 +1,73 @@
+\
+\ Purpose: temporarly switch off all actions until
+\ a delimiting word is found and executed.
+\ Useful to comment larger text parts.
+\
+\ (( switches to a limited command set and
+\ makes all words no-operations. Only words
+\ in a special wordlist are allowed for
+\ execution. )) is one of them and switches
+\ back to normal operation.
+\
+\ The recognizer switch survives REFILL's so
+\ multi line comments work too. This is an
+\ example for replacing the whole system
+\ recognizer stack with another one.
+\
+\ Author: Matthias Trute
+\ Date: Oct 14, 2016
+\ License: Public Domain
+\
+
+\ keep the previously active forth-recognizer stack
+variable old-f-rs
+wordlist constant comment-actions
+
+get-current
+comment-actions set-current
+
+\ only words in this wordlist are executed inside comments
+\ at least the )) is needed.
+
+\ switch back to the saved recognizer stack
+: ))
+ old-f-rs @ to forth-recognizer
+; immediate
+
+\ that's all for the comment actions
+set-current
+
+\ every word found is fine. Even the ones that are not found
+\ in the dictionary
+' noop dup dup recognizer: r:skip
+: rec:skip ( addr len -- r:skip ) 2drop r:skip ;
+
+\ search only in the comment-actions wordlist
+: rec:comment-actions ( addr len -- xt +/-1 r:word | r:fail )
+ comment-actions search-wordlist ( xt +/-1 | 0 )
+ ?dup if r:word else r:fail then
+;
+
+\ a simple two-element recognizer stack
+2 recognizer constant rs:comment
+' rec:skip ' rec:comment-actions 2 rs:comment set-recognizers
+
+\ save the current recognizer stack and
+\ switch over to the limited one
+: (( ( -- )
+ forth-recognizer old-f-rs !
+ rs:comment to forth-recognizer
+; immediate
+
+\ ------------- Test Cases ----------------
+\
+\ : rec:comment rs:comment do-recognizer ;
+\ T{ S" DUP" rec:comment -> r:skip }T
+\ T{ S" 1234" rec:comment -> r:skip }T
+
+\ the XT of )) is not important
+\ T{ S" ))" rec:comment rot drop -> 1 r:word }T
+\
+\ ------------------------------------------
+\ with nesting the [IF] [ELSE] [THEN] can be
+\ implemented likewise.
diff --git a/amforth-6.5/examples/rec-name.frt b/amforth-6.5/examples/rec-name.frt
new file mode 100644
index 0000000..3957133
--- /dev/null
+++ b/amforth-6.5/examples/rec-name.frt
@@ -0,0 +1,18 @@
+
+\ #require recognizer.frt
+\ #require find-name.frt
+
+\ from forth 2012
+:noname name>interpret execute ;
+:noname name>compile execute ;
+:noname postpone literal ;
+recognizer: r:name
+
+\ the parsing word
+: rec:name ( addr len -- nt r:name | r:fail)
+ find-name ?dup
+ if r:name else r:fail then
+;
+
+\ replace rec:word with rec:name
+\ everthing else should work as before
diff --git a/amforth-6.5/examples/run-hayes.frt b/amforth-6.5/examples/run-hayes.frt
new file mode 100644
index 0000000..3549977
--- /dev/null
+++ b/amforth-6.5/examples/run-hayes.frt
@@ -0,0 +1,26 @@
+\
+\ process this file with amforth-upload.py and
+\ the proper setting of $AMFORTH_LIB (basedir of
+\ you amforth file tree)
+\ WIN (untested, DOS Box)
+\ cd c:\amforth-x.y
+\ set AMFORTH_LIB=c:\amforth-x.y
+\ python tools\amforth-upload.py -t com1: examples\run-hayes.frt
+\ UNIX / MAC (Terminal)
+\ cd $HOME/amforth-x.y
+\ export AMFORTH_LIB=$HOME/amforth-x.y
+\ tools/amforth-upload.py -t /dev/ttyUSB0 examples/run-hayes.frt
+\ enjoy!
+\
+\ it is meant to be run on a newly flashed
+\ controller, e.g. all the dict_* are included
+\
+
+\ include all sources
+#include ans94/core.frt
+#include ans94/tester/tester-amforth.frt
+#include ans94/double.frt
+#include ans94/core-ext/marker.frt
+\ and finally run all the tests
+
+#include ans94/tester/core.fr
diff --git a/amforth-6.5/examples/scope.frt b/amforth-6.5/examples/scope.frt
new file mode 100644
index 0000000..d6a5d31
--- /dev/null
+++ b/amforth-6.5/examples/scope.frt
@@ -0,0 +1,21 @@
+\ The following example shows how to create a library of words under a special
+\ wordlist (can_lib). This example also shows how to chain scope calls safely.
+
+wordlist constant can_lib
+
+get-order 1+ can_lib swap set-order \ can_lib would be searched first
+
+: can_scope ( addr len -- addr' len' wid )
+ 2dup
+ 4 > if \ name length check
+ s" can_" tuck icompare if \ name prefix check
+ 4 /string \ drop prefix from created word
+ can_lib exit
+ then
+ else
+ drop
+ then
+ [ ' wlscope defer@ ] literal execute
+;
+
+' can_scope is wlscope
diff --git a/amforth-6.5/examples/sierpinsi.frt b/amforth-6.5/examples/sierpinsi.frt
new file mode 100644
index 0000000..19fe920
--- /dev/null
+++ b/amforth-6.5/examples/sierpinsi.frt
@@ -0,0 +1,26 @@
+\ Sierpinski fractal
+\ richard.w@gmail.com, clf 13.2.2015
+
+\ additional words from the forth lib
+\ #require buffer.frt
+\ #require blank.frt
+\ #require chars.frt
+
+64 constant size
+char * constant '*'
+size buffer: line[]
+
+line[] size blank '*' size 2/ chars line[] + c! ( init )
+
+: .line[] ( -- ) line[] size type cr ;
+: =*? ( addr -- f ) c@ '*' = ;
+: >char ( f f -- ch ) xor [ '*' bl - ] literal and bl + ;
+: init-flags ( -- f-1 f0 ) 0 line[] =*? ;
+: sierp-line ( -- ) init-flags line[] size bounds do
+ i 1 chars + =*? rot over >char i c!
+ loop 2drop ;
+: sierpinski ( -- ) size 2/ 0 do .line[] sierp-line loop ;
+
+\
+\ sierpinski prints the fractal on the terminal
+\ \ No newline at end of file
diff --git a/amforth-6.5/examples/sieve.frt b/amforth-6.5/examples/sieve.frt
new file mode 100644
index 0000000..13c45f2
--- /dev/null
+++ b/amforth-6.5/examples/sieve.frt
@@ -0,0 +1,58 @@
+\ sieve benchmark, modified version of
+\ marcel hendrix' sources. Uses single bits
+\ insted of whole bytes to store the is-prime
+\ marker cuts memory footprint to 1/8th.
+
+\ runtime: ATMega644 @ 16MHz 2,3 seconds per DO-PRIME
+
+marker _sieve_
+
+decimal
+
+1000 constant #times
+8192 constant size \ needs 1KB
+
+variable flags size 8 / allot
+
+\ highly un-optimized words
+: bit-addr ( addr bit -- eff-addr )
+ \ every byte has 8 bits. addr = addr + (bit >> 3)
+ 3 rshift ( -- addr off)
+ + ( -- eff-addr)
+;
+
+: bit? ( addr bit -- f )
+ swap over bit-addr swap ( -- eff-addr bit )
+ 7 and 1 swap lshift ( -- eff-addr bitmask)
+ swap c@ and ( -- f)
+;
+
+: bit-reset ( addr bit -- )
+ swap over bit-addr swap ( -- eff-addr bit )
+ 7 and 1 swap lshift ( -- eff-addr bitmask)
+ invert over c@ and swap c!
+;
+
+: 2drop drop drop ;
+
+: DO-PRIME flags [ size 8 / ] literal -1 fill
+ 0 size 0 do
+ flags i
+ bit? if
+ i 2* 3 +
+ dup i +
+ begin
+ dup
+ size u<
+ while
+ flags over bit-reset
+ over +
+ repeat
+ 2drop 1+
+ then
+ loop ;
+
+: primes cr #times u. ." iterations."
+ 0 #times 0 do drop DO-PRIME loop
+ cr . ." primes found, " ;
+
diff --git a/amforth-6.5/examples/stack.frt b/amforth-6.5/examples/stack.frt
new file mode 100644
index 0000000..b640cfb
--- /dev/null
+++ b/amforth-6.5/examples/stack.frt
@@ -0,0 +1,76 @@
+\
+\ separate stacks for cell sized data
+\
+\ Date: Nov 13, 2016
+\ Author: Matthias Trute
+
+\ allocate a stack region with at most
+\ size elements
+: stack ( size -- stack-id )
+ 1+ ( size ) cells here swap allot
+ 0 over ! \ empty stack
+;
+
+\ replace the stack content with data from
+\ the data stack.
+: set-stack ( rec-n .. rec-1 n recstack-id -- )
+ over 0< if -4 throw then \ stack underflow
+ 2dup ! cell+ swap cells bounds
+ ?do i ! 1 cells +loop
+;
+
+\ read the whole stack to the data stack
+: get-stack ( recstack-id -- rec-n .. rec-1 n )
+ dup @ >r r@ cells + r@ begin
+ ?dup
+ while
+ 1- over ( -- a n a )
+ @ ( -- a n r_i)
+ rot 1 cells -
+ rot ( -- r_i a n )
+ repeat
+ drop r>
+;
+
+\ execute XT for earch element of the stack
+\ leave the loop if the XT returns TRUE
+: map-stack ( i*x XT stack-id -- j*y f )
+ dup cell+ swap @ cells bounds ?do
+ ( -- i*x XT )
+ i @ swap dup >r execute
+ ?dup if r> drop unloop exit then
+ r> 1 cells +loop
+ drop 0
+;
+
+\ add an item as new top of the stack
+: >stack ( x stack-id -- )
+ 2dup 2>r nip get-stack 2r> rot 1+ swap set-stack
+;
+
+\ destructivly get Top Of Stack
+: stack> ( stack-id -- x )
+ dup >r get-stack 1- r> rot >r set-stack r>
+;
+
+\ actual stack depth
+: depth-stack ( stack-id -- n )
+ @
+;
+
+\ copy a stack item
+: pick-stack ( n stack-id -- n' )
+ 2dup depth-stack 0 swap within 0= if -9 throw then
+ cell+ swap cells + @
+;
+
+\ add an item at the bottom of a stack
+: >back ( x stack-id -- )
+ dup >r get-stack 1+ r> set-stack
+;
+
+\ destructivly get Bottom Of Stack
+: back> ( stack-id -- x )
+ dup >r get-stack 1- r> set-stack
+;
+
diff --git a/amforth-6.5/examples/string-rec.frt b/amforth-6.5/examples/string-rec.frt
new file mode 100644
index 0000000..b1bd930
--- /dev/null
+++ b/amforth-6.5/examples/string-rec.frt
@@ -0,0 +1,28 @@
+
+\ use " as string delimiters. Everything
+\ between two " is a string. It replaces
+\ the forth command s" completly
+\ instead of s" foo" use "foo". The space
+\ after s" is no longer needed, instead it
+\ a part of the string. s" foo" and " foo"
+\ differ with the leading space in the latter
+
+\ strings live as long as the SOURCE is
+\ unchanged! Compilation is done to the
+\ flash if called in compile state.
+\ postponing a compiled string is not yet
+\ supported.
+
+\ #require recognizer.frt
+
+' noop
+:noname postpone sliteral ;
+:noname -48 throw ; recognizer: r:string
+
+: rec:string ( addr len -- addr' len' r:string | r:fail )
+ over c@ [char] " <> if 2drop r:fail exit then
+ negate 1+ >in +! drop \ reset parse area to SOURCE
+ [char] " parse \ get trailing delimiter
+ -1 /string
+ r:string
+;
diff --git a/amforth-6.5/examples/time-rec.frt b/amforth-6.5/examples/time-rec.frt
new file mode 100644
index 0000000..9fa77e8
--- /dev/null
+++ b/amforth-6.5/examples/time-rec.frt
@@ -0,0 +1,59 @@
+
+\ recognize a time information in the format
+\ hh:mm:ss (two : between numbers)
+\ returns either r:fail (if unsuccessful) or
+\ a double number representing the seconds of the
+\ time stamp
+
+\ append it to the recognizer stack with
+\ ' rec:h:m:s get-recognizers 1+ set-recognizers
+\ and than enter 02:00:00 to get 7200. (double
+\ cell number) which is the number of seconds
+\ 2 hours have.
+
+#require m-star-slash.frt
+
+\ some factors.
+\ is the character a ':' ?
+: ':'? ( addr len -- addr+1 len-1 f )
+ over >r 1 /string r> c@ [char] : = ;
+
+\ extract a number from the current string
+: get-number ( addr len -- d addr' len' )
+ 0. 2swap >number
+;
+
+\ (hours*60+minutes)*60+seconds, factor during calculation
+: a+60b 2swap 60 1 m*/ d+ ;
+
+: rec:h:m:s ( c-addr u -- d r:dnum | r:fail )
+ get-number ( -- hh. addr len )
+ ':'? 0= if 2drop 2drop r:fail exit then
+
+ get-number ( -- hh. mm. addr+1 len-1 )
+ \ add hours to minutes
+ 2>r a+60b 2r>
+ ':'? 0= if 2drop 2drop r:fail exit then
+
+ get-number \ -- (hh*60+mm). ss. addr len
+ \ len must now be 0 or its not a time stamp
+ if drop 2drop 2drop r:fail exit then drop
+ \ add minutes to seconds and finish
+ a+60b r:dnum
+;
+
+\ wishlist:
+\ validate the values for minutes and seconds (between 0 and 59)
+\ factor the code
+\ add milliseconds?
+
+\ test cases (xy=XT of r:dnum, ab=XT of r:fail)
+\ tests are made outside of the interpreter, thus the
+\ need for explicit strings.
+
+\ > s" 01:00:00" rec:h:m:s . d.
+\ xy 3600
+\ > s" 01:00:0a" rec:h:m:s .
+\ ab
+\ > s" 72:00:09" rec:h:m:s . d.
+\ xy 259200
diff --git a/amforth-6.5/examples/value-variations.frt b/amforth-6.5/examples/value-variations.frt
new file mode 100644
index 0000000..df7ec91
--- /dev/null
+++ b/amforth-6.5/examples/value-variations.frt
@@ -0,0 +1,65 @@
+\ This file contains variations of the
+\ standard VALUE. in amforth values are
+\ stored in EEPROM and occupy 1 cell (2bytes).
+\ Calling the name of a value returns this
+\ information on the stack. With the command
+\ TO this data can be changed. Implementation
+\ allows to extend this schema to any data
+\ in any memory.
+
+\ First example is a 1byte value in RAM:
+
+\ two helper words,
+: c@v @i c@ ;
+: c!v @i c! ;
+
+: cvalue ( n "name" -- )
+ (value) \ create a new wordlist entry
+ here , \ the address for the methods
+ postpone c@v \ method for the read operation
+ postpone c!v \ method for the write (TO) operation
+ here 1 allot ! \ allocate the memory and initialize it
+ ;
+
+\ $dead cvalue answer will store only the lower byte
+\ of the number ($ad). The upper byte is either ignored
+\ (TO) or set to 0
+
+
+\ a buffered value is a value that tolerates heavy write access
+\ by using a RAM cell as a cache.
+
+\ you need to define a trigger, that flushes the cache
+\ warm-cache initializes the cache with the stored data
+\ (to be called in turnkey and similiar actions)
+
+\ it is a matter of style whether a sequence should be
+\ ' vvv method
+\ or
+\ method vvv
+\ is used. The implementation below goes the first way
+\ since parsing words are considered suboptimal by the
+\ gurus (they are state smart and less flexible)
+
+\ 2 is a magic number
+: @cache 2 + @i @ ;
+: !cache 2 + @i ! ;
+
+: flush-cache 1+ dup 2 + @i @ swap @i !e ;
+: warm-cache 1+ dup @i @e swap 2 + @i ! ;
+
+: cache-value
+ (value)
+ dup ehere dup , dup cell+ to ehere !e
+ postpone @cache
+ postpone !cache
+ here 2 ( 1 cell ) allot dup , ! \ 3 address units, remember?
+;
+
+\ \ test case
+\ ehere dup . \ keep the eeprom address
+\ 42 cache-value c-dp
+\ 17 to c-dp
+\ c-dp . dup @e . \ prints 17 and 42
+\ ' c-dp flush-cache
+\ c-dp . dup @e . \ prints 17 and 17