130 lines
3.7 KiB
Forth
130 lines
3.7 KiB
Forth
\ sdb.fs Simple database. Gforth 0.7.0 specific
|
|
' noop is bootmessage
|
|
|
|
wordlist constant USER: \ USER functions
|
|
wordlist constant SDB \ DB keys
|
|
wordlist constant FIELDS \ DB fields
|
|
|
|
: -SDB?EXIT ( -- ; Continue if `SDB' non-empty )
|
|
SDB cell+ @ 0= IF rdrop exit THEN ;
|
|
|
|
\ MACROS
|
|
: |comp| ( MACRO: | code to be compiled | )
|
|
char parse evaluate ; immediate
|
|
: LIST ( node -- ) ]] BEGIN @ dup WHILE >R [[ ; immediate
|
|
: LOOP-LIST ( -- ) ]] R> REPEAT drop [[ ; immediate
|
|
: UNLIST ( -- ) POSTPONE rdrop ; immediate
|
|
|
|
\ Helper words
|
|
: .; [char] ; emit ;
|
|
: !+ dup cell+ -rot ! ;
|
|
: ($+) ( cas us cad ud -- cad us+ud ; append source string to destination )
|
|
swap >R 2dup + R> swap >R tuck + swap >R swap move R> R> ;
|
|
|
|
\ --- Working Record Fields
|
|
current @ FIELDS current !
|
|
2variable person
|
|
2variable birthday
|
|
2variable relationship
|
|
2variable hobby
|
|
current ! FIELDS >order
|
|
|
|
\ --- Ring list
|
|
: new-node ( -- node ; root of circular list )
|
|
here dup , ;
|
|
: do-link ( node new-node -- ; do link after current node )
|
|
over @ over ! swap ! ;
|
|
: empty-ring? ( node -- f ) dup @ = ;
|
|
|
|
: RING ( node -- ) ]] dup BEGIN @ 2dup <> WHILE 2>R [[ ; immediate
|
|
: LOOP-RING ( -- ) ]] 2R> REPEAT 2drop [[ ; immediate
|
|
: UNRING ( -- ) postpone 2RDROP ; immediate
|
|
|
|
:noname
|
|
s" " person 2! s" 9999.01.01" birthday 2! s" " relationship 2! s" " hobby 2! ;
|
|
new-node swap , CONSTANT OLD
|
|
|
|
\ --- Insertion into ring
|
|
: node>xt ( node -- xt ) cell+ @ ;
|
|
: bday@ ( node -- ca u ) node>xt execute birthday 2@ ;
|
|
: datecmp ( node node -- -1|0|1 ) bday@ rot bday@ compare ;
|
|
|
|
: search-by-date ( new-node node -- node' ; Linear search by birth date )
|
|
dup
|
|
RING ( new-node node )
|
|
over I datecmp 0<
|
|
IF nip UNRING exit
|
|
ELSE drop I THEN
|
|
LOOP-RING nip ;
|
|
|
|
: insert-ordered ( new-node -- )
|
|
OLD dup empty-ring? 0=
|
|
IF over swap search-by-date THEN swap do-link ;
|
|
|
|
\ --- Field compiling
|
|
: fld: [char] ; parse postpone sliteral ; immediate
|
|
|
|
: _sdb-walk ( MACRO: | xt[--] -- | )
|
|
]] -SDB?EXIT here dup SDB cell+
|
|
LIST I name>int swap !+ LOOP-LIST [[ 1 cells ]] literal -
|
|
DO I @ |comp| [[ -1 cells ]] literal +LOOP [[ ; immediate
|
|
|
|
2variable category
|
|
: msg_nocategory ( -- )
|
|
." No such category!" cr ;
|
|
|
|
\ --- USER definitions
|
|
user: >order current @ USER: current !
|
|
: bye bye ;
|
|
: .s .s ;
|
|
: newline cr ;
|
|
: godb SDB >order ;
|
|
: .keys SDB wordlist-words ;
|
|
: .person person 2@ type ;
|
|
: .birthday birthday 2@ type ;
|
|
: .relationship relationship 2@ type ;
|
|
: .hobby hobby 2@ type ;
|
|
: .record .person 1 spaces .birthday .; .relationship .; .hobby .; ;
|
|
|
|
: .last SDB cell+ @ dup
|
|
IF name>int execute .record ELSE drop THEN ;
|
|
|
|
: .lastbycategory ( "field-name" -- )
|
|
here 0 category 2! parse-name FIELDS search-wordlist
|
|
IF sdb cell+
|
|
LIST ( xt )
|
|
I name>int execute dup execute 2@ category 2@ 2swap search nip nip 0=
|
|
IF .record cr dup execute 2@ category 2@ ($+) category 2! THEN
|
|
LOOP-LIST drop
|
|
ELSE ['] msg_nocategory stderr OUTFILE-EXECUTE THEN ;
|
|
|
|
: .bydate ( -- )
|
|
OLD RING I node>xt execute .record cr LOOP-RING ;
|
|
|
|
: .sdb _sdb-walk | execute .record cr | ;
|
|
: sdb-dump _sdb-walk | execute ." +: " .record cr | ;
|
|
|
|
: dump ( "db-file" -- )
|
|
parse-name w/o
|
|
CREATE-FILE throw dup
|
|
['] sdb-dump swap OUTFILE-EXECUTE
|
|
CLOSE-FILE throw ;
|
|
|
|
: load ( "db-file" -- ) include ;
|
|
|
|
: +: ( "person birth-day;relationship;hobby; -- )
|
|
new-node dup cell+ >R 0 , \ post `xt'
|
|
current @ SDB current ! \ compile into `sdb' wordlist
|
|
: latestxt dup R> ! \ fix-up `xt'
|
|
]] literal >name name>string person 2! fld: birthday 2! fld: relationship 2! fld: hobby 2! ; [[
|
|
current !
|
|
insert-ordered ;
|
|
|
|
: HELP cr
|
|
cr ." KEYWORDS: " USER: wordlist-words cr ." ---"
|
|
cr ." Prefix `.' means print"
|
|
cr ." To add a record, type: +: name yyyy.mm.dd;relationship;hobby;"
|
|
cr cr ;
|
|
current !
|
|
SEAL godb
|