From 67d25d837ac55f28a366c0a3b262e439a6e75fc3 Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Sat, 19 Aug 2017 12:15:28 +0200 Subject: Add AmForth --- amforth-6.5/examples/ascii.frt | 13 ++ amforth-6.5/examples/co.frt | 36 +++++ amforth-6.5/examples/date-time.frt | 29 ++++ amforth-6.5/examples/easter.frt | 112 +++++++++++++ amforth-6.5/examples/fib.frt | 12 ++ amforth-6.5/examples/forward-declarations-test.frt | 12 ++ amforth-6.5/examples/forward-declarations.frt | 23 +++ amforth-6.5/examples/fsm.frt | 67 ++++++++ amforth-6.5/examples/i2c-compass.frt | 55 +++++++ amforth-6.5/examples/life.frt | 178 +++++++++++++++++++++ amforth-6.5/examples/literacy.frt | 49 ++++++ amforth-6.5/examples/local.frt | 64 ++++++++ amforth-6.5/examples/many.frt | 13 ++ amforth-6.5/examples/parsed-to.frt | 22 +++ amforth-6.5/examples/queens.frt | 54 +++++++ amforth-6.5/examples/readme.txt | 37 +++++ amforth-6.5/examples/rec-char.frt | 12 ++ amforth-6.5/examples/rec-double-paren.frt | 73 +++++++++ amforth-6.5/examples/rec-name.frt | 18 +++ amforth-6.5/examples/run-hayes.frt | 26 +++ amforth-6.5/examples/scope.frt | 21 +++ amforth-6.5/examples/sierpinsi.frt | 26 +++ amforth-6.5/examples/sieve.frt | 58 +++++++ amforth-6.5/examples/stack.frt | 76 +++++++++ amforth-6.5/examples/string-rec.frt | 28 ++++ amforth-6.5/examples/time-rec.frt | 59 +++++++ amforth-6.5/examples/value-variations.frt | 65 ++++++++ 27 files changed, 1238 insertions(+) create mode 100644 amforth-6.5/examples/ascii.frt create mode 100644 amforth-6.5/examples/co.frt create mode 100644 amforth-6.5/examples/date-time.frt create mode 100644 amforth-6.5/examples/easter.frt create mode 100644 amforth-6.5/examples/fib.frt create mode 100644 amforth-6.5/examples/forward-declarations-test.frt create mode 100644 amforth-6.5/examples/forward-declarations.frt create mode 100644 amforth-6.5/examples/fsm.frt create mode 100644 amforth-6.5/examples/i2c-compass.frt create mode 100644 amforth-6.5/examples/life.frt create mode 100644 amforth-6.5/examples/literacy.frt create mode 100644 amforth-6.5/examples/local.frt create mode 100644 amforth-6.5/examples/many.frt create mode 100644 amforth-6.5/examples/parsed-to.frt create mode 100644 amforth-6.5/examples/queens.frt create mode 100644 amforth-6.5/examples/readme.txt create mode 100644 amforth-6.5/examples/rec-char.frt create mode 100644 amforth-6.5/examples/rec-double-paren.frt create mode 100644 amforth-6.5/examples/rec-name.frt create mode 100644 amforth-6.5/examples/run-hayes.frt create mode 100644 amforth-6.5/examples/scope.frt create mode 100644 amforth-6.5/examples/sierpinsi.frt create mode 100644 amforth-6.5/examples/sieve.frt create mode 100644 amforth-6.5/examples/stack.frt create mode 100644 amforth-6.5/examples/string-rec.frt create mode 100644 amforth-6.5/examples/time-rec.frt create mode 100644 amforth-6.5/examples/value-variations.frt (limited to 'amforth-6.5/examples') 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: +\ Subject: String literacy +\ From: Julian Fondren +\ 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 -- cgit v1.2.3