138 lines
4.5 KiB
Forth
138 lines
4.5 KiB
Forth
\ Written in ANS-Forth; tested under VFX.
|
|
\ Requires the novice package: http://www.forth.org/novice.html
|
|
\ The following should already be done:
|
|
\ include novice.4th
|
|
\ include association.4th
|
|
|
|
\ I would define high-level languages as those that allow programs to be written without explicit iteration. Iteration is a major source of bugs.
|
|
\ The example from the FFL library doesn't hide iteration, whereas this example from the novice-package does.
|
|
|
|
|
|
marker AssociationIteration.4th
|
|
|
|
\ ******
|
|
\ ****** The following defines a node in an association (each node is derived from ELEMENT).
|
|
\ ******
|
|
|
|
element
|
|
w field .inventor
|
|
constant language \ describes a programming language
|
|
|
|
: init-language ( inventor name node -- node )
|
|
init-element >r
|
|
hstr r@ .inventor !
|
|
r> ;
|
|
|
|
: new-language ( inventor name -- node )
|
|
language alloc
|
|
init-language ;
|
|
|
|
: show-language ( count node -- )
|
|
>r
|
|
1+ \ -- count+1
|
|
cr r@ .key @ count colorless type ." invented by: " r@ .inventor @ count type
|
|
rdrop ;
|
|
|
|
: show-languages-forward ( handle -- )
|
|
0 \ -- handle count
|
|
swap .root @ ['] show-language walk>
|
|
cr ." count: " .
|
|
cr ;
|
|
|
|
: show-languages-backward ( handle -- )
|
|
0 \ -- handle count
|
|
swap .root @ ['] show-language <walk
|
|
cr ." count: " .
|
|
cr ;
|
|
|
|
: kill-language-attachments ( node -- )
|
|
dup .inventor @ dealloc
|
|
kill-key ;
|
|
|
|
: copy-language-attachments ( src dst -- )
|
|
over .inventor @ hstr
|
|
over .inventor !
|
|
copy-key ;
|
|
|
|
|
|
\ ******
|
|
\ ****** The following defines the association itself (the handle).
|
|
\ ******
|
|
|
|
association
|
|
constant languages \ describes a set of programming languages
|
|
|
|
: init-languages ( record -- record )
|
|
>r
|
|
['] compare ['] kill-language-attachments ['] copy-language-attachments
|
|
r> init-association ;
|
|
|
|
: new-languages ( -- record )
|
|
languages alloc
|
|
init-languages ;
|
|
|
|
|
|
\ ******
|
|
\ ****** The following filters one association into another, including everything that matches a particular inventor.
|
|
\ ******
|
|
|
|
: <filter-inventor> { inventor handle new-handle node -- inventor handle new-handle }
|
|
inventor count node .inventor @ count compare A=B = if
|
|
node handle dup-element new-handle insert then
|
|
inventor handle new-handle ;
|
|
|
|
: filter-inventor ( inventor handle -- new-handle )
|
|
dup similar-association \ -- inventor handle new-handle
|
|
over .root @ ['] <filter-inventor> walk> \ -- inventor handle new-handle
|
|
nip nip ;
|
|
|
|
\ ******
|
|
\ ****** The following is a demonstration with some sample data.
|
|
\ ******
|
|
|
|
|
|
new-languages
|
|
c" Moore, Chuck" c" Forth " new-language over insert
|
|
c" Ichiah, Jean" c" Ada " new-language over insert
|
|
c" Wirth, Niklaus" c" Pascal " new-language over insert
|
|
c" Wirth, Niklaus" c" Oberon " new-language over insert
|
|
c" McCarthy, John" c" Lisp " new-language over insert
|
|
c" van Rossum, Guido" c" Python " new-language over insert
|
|
c" Gosling, Jim" c" Java " new-language over insert
|
|
c" Ierusalimschy, Roberto" c" Lua " new-language over insert
|
|
c" Matsumoto, Yukihiro" c" Ruby " new-language over insert
|
|
c" Pestov, Slava" c" Factor " new-language over insert
|
|
c" Gosling, James" c" Java " new-language over insert
|
|
c" Wirth, Niklaus" c" Modula-2 " new-language over insert
|
|
c" Ritchie, Dennis" c" C " new-language over insert
|
|
c" Stroustrup, Bjarne" c" C++ " new-language over insert
|
|
constant some-languages
|
|
|
|
|
|
cr .( everything in SOME-LANGUAGES ordered forward: )
|
|
|
|
some-languages show-languages-forward
|
|
|
|
|
|
cr .( everything in SOME-LANGUAGES ordered backward: )
|
|
|
|
some-languages show-languages-backward
|
|
|
|
|
|
cr .( everything in SOME-LANGUAGES invented by Wirth: )
|
|
|
|
c" Wirth, Niklaus" some-languages filter-inventor dup show-languages-forward kill-association
|
|
|
|
|
|
cr .( everything in SOME-LANGUAGES within 'F' and 'L': )
|
|
|
|
c" F" c" L" some-languages filter within dup show-languages-forward kill-association
|
|
|
|
|
|
cr .( everything in SOME-LANGUAGES not within 'F' and 'L': )
|
|
|
|
c" F" c" L" some-languages filter without dup show-languages-forward kill-association
|
|
|
|
|
|
some-languages kill-association
|