Initial data commit

Task/Simple-database/Forth/simple-database.fth

@@ -0,0 +1,129 @@
+\ 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