Artifact 78e8a208006edbf145c5efc6f00b34836c04691a

File user/docl/tables.retro part of check-in [43c05897c2] - fixes, refactoring by luke on 2010-06-06 19:55:28. [annotate]

( --- tools for dealing with lists --- )
: deep    ( an-a) 0; for @ next ;
: deepest ( a-a ) repeat dup @ 0; nip again ;
: link,   ( a-  ) here 0 , swap deepest ! ;
( --- output types --- )
: chars for @+ emit next ;
: string: .data ` type ; immediate
: phone char: ( emit 3 chars char: ) emit 
  3 chars char: - emit 4 chars drop ;
: phone: .data ` phone ; immediate
: date 2 chars char: / emit 2 chars char: / emit 4 chars drop ;
: date: .data ` date ; immediate
: dollar 100 /mod (.) char: . emit dup 9 <if 0 (.) then (.) ;
: dollar: .data ` dollar ; immediate
( --- tables: fields/offsets, rows/links, etc. --- )
variable table
variable row
: save ( "- ) @table constant ;
: load ( a- ) !table ;
: link @table ;    ( least recent row added )
: head @table 1+ ; ( header for last field )
: size  head  1+ ; ( number of fields )
: fields dup for ' create r , , next
  here !table 0 , @last , , ;
: f:num @ ;
: f:xt f:num @row + @ ;
: f:fun 1+ @ ;
: f:pair dup f:xt swap f:fun ;
: num:f @head swap 1- deep @d->xt ;
: row,   (  a- ) here !row link link, @size allot ;
: insert ( n"- ) ' f:num @row + ! ;
: nwhere (  n- ) @link swap deep !row ;
: select-list ( n"- ) for ' f:pair cr with-class next ;
: select-all  (   - ) @size for r num:f f:pair cr with-class next ;
( --- input methods --- )
{{
: cents '. =if 100 * key dup emit 48 - 10 * key dup emit 48 - + + then ;
---reveal---
: keep: here repeat key dup 32 =if drop 0 , ;then dup emit , again ;
: num: 0 repeat key dup emit dup 48 57 within if 48 - swap 10 * + else cents ;then again ; 
}}
( --- example table --- )
vocab mytable ((
4 fields string: name phone: number date: birthdate dollar: paycheck
))
( --- test inputs --- )
row,
0 nwhere
keep: Luke
insert name
keep: 9998887777
insert number
keep: 06201983
insert birthdate
num: 99999.99
insert paycheck
row,
keep: Samuel
insert name
keep: 5554443333
insert number
keep: 12345678
insert birthdate
num: 999999.99
insert paycheck
( --- test outputs --- )
select-all
0 nwhere
select-all