Power-Programmierung/CD1.mdf/forth/rbsrc/filesys.scr

Text File | 1988-04-30 | 62KB | 1 lines

( File System                              HS  09:57 11/22/86 ) ( Last change:   Screen  011               hs  12:15 12/27/86 )                                                                                                                                                                                                          *****************************************                       *   F A R   S I D E   R E S E A R C H   *                       *           (C) 1985,1986               *                       *****************************************                                                                                                                                                                                                              UR/Forth Verision                                                                                                                                                                                                                                               ( Description                                  13:42 12/27/86 )                                                                 \ This basic subdivisions of this file system are:              \  <DICTIONARY>                                                 \      <ITEM>                                                   \         <FIELD>                                               \            <LINK>                                             \                                                               \ DICTIONARY - A standard collection of n ITEMS and a header    \              ITEMS.                                           \ ITEM       - A collection of data which is related and stored \              in a DICTIONARY                                  \ FIELD      - An ITEM is divided into fields, these are named  \              and are really offset into the ITEM.             \ LINK       - a FIELD which points to a record in the same or  \              different DICTIONARY.                            ( dictionary - def.                            14:10 12/12/86 )                                                                 \ This word parses the input string twice: the first time for   \ the DICTIONARY name, the second time for the filespec.        \ It is not necessary to add the ext. .DCT for it is added by   \ the word. Usage: DICTIONARY NAME1 \FILESPEC                   ( -- )                                                          : DICTIONARY   CREATE  0 , 0 , HERE >R 80 ALLOT                                R@ 80 ERASE BL WORD COUNT 1+ SWAP 1- SWAP                       R@ SWAP CMOVE                                                   R@ COUNT ASCII . SCAN SWAP DROP 0= IF                           " .DCT" 1+ R@ C@ R@ 1+ + 4 CMOVE THEN                           R@ C@ 4 + R> C!                                                 0 , 12 ALLOT                                                    DOES> ;                                                                                                          ( dict. record defs.                           13:15 12/12/86 )                                                                 ( dictionary -- addr of fld )                                   : D.HEADER   86 +          ;     \ header record from file      : D.ITEM-SZ  D.HEADER      ;     \ size of each record          : D.HU       D.HEADER 2+   ;     \ highest used                 : D.NA       D.HEADER 4 +  ;     \ no of active records         : D.LST-READ D.HEADER 6 +  ;     \ last record read             : D.LST-WRIT D.HEADER 8 +  ;     \ last record written          : D.ASCIIZ   4 +           ;     \ asciiz string of file                                                                        ( icb or dcb --- -1 for index, 0 for index )                    : ?TYPE      84 + @ ;                                                                                                                                                                                                                                           ( dictionary operation                         08:23 11/26/86 )                                                                                                                                 ( dictionary -- )                                               : READ-HEADER  DUP 0. 0 FSEEK 2DROP                                            DUP D.HEADER 12 FREAD DROP ;                                                                                     ( dictionary -- )                                               : WRITE-HEADER DUP 0. 0 FSEEK 2DROP                                            DUP D.HEADER 12 FWRITE DROP ;                                                                                                                                                                                                                                                                                                                                                                                                                    \ Open-dict                                    1 12:08 12/18/87                                                                 ( addr of dict -- )                                             : OPEN-DICTIONARY DUP 2 FOPEN DROP                                                READ-HEADER ;                                                                                                 ( addr of dict -- )                                             : CLOSE-DICTIONARY DUP WRITE-HEADER                                                FCLOSE DROP ;                                                                                                ( rec-sz,addr-of dict -- )                                      : MAKE-DICTIONARY  DUP >R D.HEADER 12 ERASE     \ clear header                     R@ D.ITEM-SZ !               \ put in size                      R@ 0 FMAKE DROP              \ make the file                    R@ WRITE-HEADER              \ zero'd header                    R> FCLOSE DROP ;                             ( dict-read & dict-write                       14:36 12/12/86 )                                                                 \ This word sets the file * to the appropriate place            ( ent#,dictionary -- )                                          : DICT-POS   DUP D.ITEM-SZ @ ROT UM* 12. D+ ROT DUP >R                       0. 1 FSEEK D- R> -ROT 1 FSEEK 2DROP ;                                                                              \ This word read the specified ITEM into the specified buffer   ( buffer,ent#,dictionary -- )                                   : DICT-READ   OVER OVER D.LST-READ ! SWAP OVER DICT-POS DUP                   D.ITEM-SZ @ ROT SWAP FREAD DROP ;                                                                                 \ This word writes the specified ITEM from specified buffer     ( buffer,ent#,dictionary -- )                                   : DICT-WRITE  OVER OVER D.LST-WRIT ! SWAP OVER DICT-POS DUP                   D.ITEM-SZ @ ROT SWAP FWRITE DROP ;                ( find-nxt-deleted                             08:54 12/15/86 )                                                                 ( dictionary -- rec + 1 , 0 for none deleted )                  : FIND-NXT-DELETED  DUP D.HU @ OVER D.NA @ = IF DROP 0 EXIT THEN                    0 SWAP DUP D.HU @                                               0 ?DO                                                               I OVER DICT-POS                                                 DUP TIB 1 FREAD DROP                                            TIB C@ 229 = IF NIP I 1+ SWAP LEAVE THEN                      LOOP                                                          DROP ;                                                                                                                                                                                                                                                                                                                                                                      ( add-record                                   09:12 12/15/86 )                                                                 \ This word adds a record the specified dictionary              ( buff, dictionary -- record number )                           : ADD-ITEM    DUP FIND-NXT-DELETED                                             ?DUP IF 1- SWAP DUP 1 SWAP D.NA +!                                   ELSE DUP D.HU @ SWAP DUP                                             1 SWAP D.NA +! DUP                                              1 SWAP D.HU +!                                             THEN                                                       DUP WRITE-HEADER                                                OVER >R DICT-WRITE R> ;                                                                                                                                                                                                                                                                                          ( del-record                                   09:40 12/15/86 )                                                                 \ This record deletes the specified record                      ( rec#, dictionary -- )                                         : DEL-ITEM    229 TIB C!                                                      SWAP OVER DICT-POS                                              DUP TIB 1 FWRITE DROP                                           DUP D.NA -1 SWAP +!                                             WRITE-HEADER ;                                                                                                                                                                    ( buffer -- t/f )                                               : ?ACTIVE     C@ 0= ;                                                                                                                                                                                                                                           ( record definitions                           10:49 12/27/86 )                                                                 \ These words define a ITEM  structure, and do nothing else.    \ They do not allocate storage space, and are really just a     \ template for data                                             \ EXAMPLE:                                                      \    0 ITEM  EMP-DATA                                           \         20 EMP-DATA  E.NAME                                   \          5 EMP-DATA  E.ZIP                                    \    END-ITEM                                                   \ EMP-DATA becomes the defining word for the ITEM . You then    \ must define a buffer and apply the fields to the buffer       \ EXAMPLE:                                                      \             SIZEOF EMP-DATA ITEM -ALLOT EMP-BUFF              \             EMP-BUFF E.NAME                                   \ This returns the offset of the E.NAME in the buffer           ( record definitions                           10:49 12/27/86 )                                                                 \ These are the actual WORDS for the definitions                : <ITEM> CREATE , DOES> @ + ;   ( size offset -- )                                                                              : ITEM   CREATE , DOES> DUP @ DUP >R ROT + SWAP ! R> <ITEM> ;                                                                   ( BEGIN-ITEM  item-name -- )                                    : BEGIN-ITEM  0 ITEM        ;                                                                                                   \ Just for readibility                                          : END-ITEM  NOOP ;     ( -- )                                                                                                   ( size of entry ITEM-ALLOT buffer name )                        : ITEM-ALLOT  CREATE ALLOT DOES> ;                                                                                              ( record definitions                           11:02 01/16/87 )                                                                 \ 'sizeof' is useful for declaring ITEM OF ITEM                 ( USAGE:  SIZEOF <ITEM> -- size )                               : SIZEOF  BL WORD FIND NOT ABORT" Undefined " >BODY @                     STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         \ Index Sections                                 09:26 02/19/88 \S                                                                   This section defines the index system that is used in      conjunction with the dictionary system.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         \ hash-str                                       16:13 03/11/88                                                                                                                                 : HASH-STR      ( saddr cnt --- )                                              -1 BEGIN                                                             1+                                                              2 PICK OVER + C@ ISALNUM >R 2DUP < R>                           OR                                                             UNTIL                                                           2DUP = IF 3DROP 0 ELSE ROT +  C@ TOUPPER +                             THEN                                                     149 MOD ;                                                                                                                                                                                                                                                                                                    \ Inode buffer & Node                        hs  15:40 02/10/88                                                                 CREATE INODE      9  ALLOT        \ buffer for current index    CREATE WNODE      9  ALLOT        \ buffer for work index                                                                       ( addr --- offset )                                             : N.FLAG           ;                                            : N.WHOAMI   1+    ;                                            : N.NXT-HASH 3 +   ;                                            : N.LST-LINK 5 +   ;                                            : N.NXT-LINK 7 +   ;                                                                                                            VARIABLE I-NEXT                   \ who i point to              VARIABLE I-LAST                   \ the one that points to me   VARIABLE I-CUR                    \ current                                                                                     \ <read-node> & <write-node>                 hs  13:22 02/09/88                                                                 : <rel-pos>    ( icb #node --- )                                               9 UM* 300. D+ ROT DUP >R 0. 1 FSEEK D-                          R> -ROT 1 FSEEK 2DROP ;                                                                                          : <read-node>  ( icb buff_addr #node --- code )                                DUP I-LAST ! ROT TUCK SWAP <rel-pos>                            SWAP 9 FREAD ;                                                                                                   : <write-node> ( icb buff_addr #node --- code )                                DUP I-LAST ! ROT TUCK SWAP <rel-pos>                            SWAP 9 FWRITE ;                                                                                                                                                                                                                                  \ ?nodes & ?hash-hits                            16:00 02/12/88                                                                 : ?nodes      ( icb --- #nodes )                                              0. 2 FSEEK DROP 300 - 9 / ;                                                                                                                                                       : ?hash-hits  ( icb --- #hits )                                               DUP 0. 0 FSEEK 2DROP                                            0 149 0 DO OVER PAD 2 FREAD DROP                                           PAD @ -1 <> IF 1+ THEN                                       LOOP NIP ;                                                                                                                                                                                                                                                                                                                                                                \ <raw-find>                                 hs  10:27 02/10/88                                                                 \ Does a sequentially search on the index for the specified item: <raw-find>  ( icb #item --- #node or -1 for not found )                     SWAP -1 -ROT                                                    DUP ?nodes                                                      0 ?DO                                                               DUP PAD I <read-node> DROP                                      OVER PAD N.WHOAMI @ = IF DROP I -ROT LEAVE                                            THEN                                     LOOP                                                         2DROP ;                                                                                                                                                                                                                                                                                                           \ <walk-hash>                                hs  13:39 02/09/88                                                                 \ Returns the last inode number for that hash, if the link list \ is traced the last record will be left in WNODE.                                                                              : <walk-hash>  ( icb hash_value --- #node or -1 for none )                     OVER SWAP 2* S>D 0 FSEEK 2DROP                                  DUP I-NEXT 2 FREAD DROP                                         I-NEXT @ WNODE N.NXT-HASH ! I-LAST ON                           BEGIN                                                              WNODE N.NXT-HASH @ -1 <>                                     WHILE                                                              DUP WNODE DUP N.NXT-HASH @ <read-node> DROP                  REPEAT                                                          DROP I-LAST @ ;                                                                                                  \ <adj-link>                                 hs  10:04 02/10/88                                                                 \ Adjusts the links for WNODE when being deleted                : <del-link>  ( icb --- )                                                     WNODE N.LST-LINK @ -1 <>                                        IF DUP INODE WNODE N.LST-LINK @ <read-node> DROP                   WNODE N.NXT-LINK @ INODE N.NXT-LINK !                          DUP INODE I-LAST @ <write-node> DROP                           THEN                                                           WNODE N.NXT-LINK @ -1 <>                                        IF DUP INODE WNODE N.NXT-LINK @ <read-node> DROP                   WNODE N.LST-LINK @ INODE N.LST-LINK !                           DUP INODE I-LAST @ <write-node> DROP                         THEN DROP ;                                                                                                                                                                       \ <del-hash>                                 hs  10:07 02/10/88                                                                 \ Deletes the node stored in WNODE and adjusts the links        : <del-hash>  ( icb #node --- )                                               OVER 0. 0 FSEEK 2DROP                                           150 0 DO OVER I-NEXT 2 FREAD DROP I-NEXT @ OVER =                     IF OVER -2. 1 FSEEK 2DROP                                          OVER WNODE N.NXT-HASH 2 FWRITE DROP                          THEN LOOP                                                 SWAP DUP ?nodes                                                 0 ?DO  DUP INODE I <read-node> DROP                                 OVER INODE N.NXT-HASH @ =                                       IF                                                                WNODE N.NXT-HASH @ INODE N.NXT-HASH !                           DUP INODE I <write-node> DROP THEN                           LOOP 2DROP ;                                   \ <add-hash>                                 hs  16:01 02/10/88                                                                                                                                 : <add-hash>  ( icb #hash --- )                                               OVER OVER <walk-hash> DUP -1 =                                  IF DROP OVER OVER 2* S>D 0 FSEEK 2DROP                             OVER I-CUR 2 FWRITE DROP                                     ELSE                                                               >R OVER WNODE R> <read-node> DROP                               I-CUR @ WNODE N.NXT-HASH !                                      OVER WNODE I-LAST @ <write-node> DROP                        THEN                                                            2DROP                                                           -1 INODE N.NXT-HASH ! ;                                                                                                                                                           \ <del-node>                                 HS  14:06 02/10/88                                                                                                                                 \ Deletes the specified node from the specified                 : <del-node>  ( icb #node --- )                                               2DUP WNODE SWAP <read-node> DROP                                DUP  I-CUR !           \ current                                OVER <del-link>        \ delete the sort links                  2DUP <del-hash>        \ deleted the hash links                 229 WNODE N.FLAG C!    \ it's deleted                           WNODE 1+ 8 ERASE       \ clear it                               WNODE INODE 9 CMOVE                                             OVER 149 <add-hash> INODE WNODE 9 CMOVE                         WNODE SWAP <write-node> DROP ;                                                                                                                                                    \ <add-link>                                 hs  17:59 02/10/88                                                                 \ Adjusts the sort links according to the ptrs in the INODE     : <add-link>  ( icb --- )                                                     INODE N.LST-LINK @ -1 <>                                        IF                                                               DUP WNODE INODE N.LST-LINK @ <read-node> DROP                   I-CUR @ WNODE N.NXT-LINK !                                      DUP WNODE I-LAST @ <write-node> DROP THEN                      INODE N.NXT-LINK @ -1 <>                                        IF                                                               DUP WNODE INODE N.NXT-LINK @ <read-node> DROP                   I-CUR @ WNODE N.LST-LINK !                                      DUP WNODE I-LAST @ <write-node> DROP THEN                      DROP ;                                                                                                            \ <find-open>                                hs  10:07 02/10/88                                                                                                                                 : <find-open> ( icb --- #node )                                               DUP 149 <walk-hash>                                             DUP -1 <>                                                       IF OVER SWAP WNODE SWAP <read-node> DROP                           I-LAST @ DUP >R <del-hash> R>                                ELSE                                                               DROP ?nodes                                                  THEN ;                                                                                                                                                                                                                                                                                                                                                                            \ <add-node>                                 hs  01:49 02/11/88                                                                 : <add-node>  ( icb lnode nnode #hash #item --- )                             4 PICK <find-open> I-CUR !                                      INODE 9 ERASE                                                   INODE N.WHOAMI !          \ put which record i am               SWAP INODE N.NXT-LINK !   \ put in my next link                 SWAP INODE N.LST-LINK !   \ put in my last link                 OVER SWAP <add-hash>      \ adjust hash chain                   DUP <add-link>            \ adjust sort links                   INODE I-CUR @ <write-node> DROP ;                                                                                                                                                                                                                                                                                                                                                 \ index                                      hs  10:13 02/12/88                                                                 \ Index definition structure for an index                       : INDEX ( cfa_cmp cfa_hsh sz_rec dcb cstr INDEX idx_name )              CREATE                                                                 0 , 0 ,                       \ hcb                             HERE >R 80 ALLOT R@ 80 ERASE                                    R> OVER C@ 1+ CMOVE           \ filename                        -1 , -1 , -1 , -1 ,           \ last,next,me                    , SWAP , SWAP ,               \ dcb,hash,cmp                    ALLOT                         \ compare buff              DOES> ;                                                                                                                                                                                                                                                                                                                \ index definitions                          hs  10:21 02/12/88                                                                 ( icb --- hcb )                                                 : IDX.HCB     ;               \ address of the hcb              : IDX.LAST  86 + ;            \ addr of last                    : IDX.NEXT  88 + ;            \ addr of next                    : IDX.ME    90 + ;            \ who i am                        : IDX.'DCB  92 + ;            \ offset of dcb                   : IDX.DCB   IDX.'DCB @ ;      \ dictionary control block        : IDX.HASH  94 + ;            \ hash dictionary                 : IDX.CMP   96 + ;            \ compare cfa                     : IDX.BUFF  98 +   ;          \ buffer for compare                                                                                                                                                                                                                                                                              \ <compare>                                      21:54 02/13/88                                                                 \ Assumes the node in INODE contains a valid node               : <compare>  ( icb item_buff #item --- 0=equals,-1=great,1=less)             >R OVER DUP IDX.BUFF SWAP R> SWAP                               IDX.DCB DICT-READ                                               SWAP DUP IDX.BUFF SWAP IDX.CMP PERFORM ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           \ <last> & <next>                                12:27 02/14/88                                                                 : <last>     ( icb --- #node or -1 for head )                                INODE N.LST-LINK @ DUP -1 =                                     IF NIP EXIT THEN                                                INODE SWAP <read-node> DROP I-LAST @ ;                                                                                                                                             : <next>     ( icb --- #node or -1 for head )                                INODE N.NXT-LINK @ DUP -1 =                                     IF NIP EXIT THEN                                                INODE SWAP <read-node> DROP I-LAST @ ;                                                                                                                                             VARIABLE dir                                                                                                                    \ zero-in                                        14:01 02/13/88                                                                 : <zero-in>    ( icb item --- lnode nnode )                                    dir OFF                                                         BEGIN                                                               2DUP INODE N.WHOAMI @ <compare>                                 CASE                                                              0 OF -1 0            ENDOF                                     -1 OF OVER <last> -1  ENDOF                                      1 OF OVER <next>  1  ENDOF                                    ENDCASE DUP dir @ SWAP dir ! + 0=                               SWAP -1 = OR                                                 UNTIL                                                           I-LAST @ INODE N.NXT-LINK @                                     2SWAP INODE N.WHOAMI @ <compare> -1 =                           IF DROP INODE N.LST-LINK @ SWAP THEN ;          \ 5*<next> & 5*<last>                            14:44 04/16/88                                                                 5 EQU #skips                                                                                                                    : 5*<next>    ( icb --- ) 0 SWAP #skips                                       0 ?DO DUP <next> -1 = IF NIP -1 SWAP LEAVE THEN                 LOOP DROP ;                                                                                                       : 5*<last>    ( icb --- t/f) 0 SWAP #skips                                    0 ?DO DUP <last> -1 = IF NIP -1 SWAP LEAVE THEN                 LOOP DROP ;                                                                                                                                                                                                                                                                                                                                                                       \ finetune                                       14:01 02/13/88                                                                 : finetune  ( icb item --- lnode nnode ) dir OFF                            2DUP INODE N.WHOAMI @ <compare> DUP                             0= IF 3DROP I-LAST @ INODE N.NXT-LINK @ EXIT THEN               BEGIN                                                             CASE                                                              0 OF -1 0               ENDOF                                  -1 OF OVER 5*<last> -1   ENDOF                                   1 OF OVER 5*<next>  1   ENDOF                                   ENDCASE DUP dir @ SWAP dir ! + 0= SWAP -1 = OR              0= WHILE 2DUP INODE N.WHOAMI @ <compare> REPEAT                 <zero-in> ;                                                                                                                                                                                                                                         \ ?IDX-POSITION                                  17:44 02/12/88                                                                                                                                 : ?IDX-POSITION ( icb item  --- lnode nnode )                                   OVER ?nodes IF OVER ?hash-hits 0=                                             IF 2DROP -1 -1 EXIT THEN                                      ELSE 2DROP -1 -1 EXIT THEN                          2DUP SWAP IDX.HASH PERFORM ( 1- 0 MAX )                         2 PICK SWAP <walk-hash> DUP -1 =                                IF DROP OVER ?nodes 0                                           ?DO OVER INODE I <read-node> DROP                                   INODE N.FLAG @ 0= IF LEAVE THEN LOOP                        ELSE >R OVER INODE R> <read-node> DROP THEN                     finetune ;                                                                                                                                                                      \ Index Add,Del,Upd                              14:18 02/13/88                                                                 : IDX-ADD    ( icb buff item# --- )                                          >R 2DUP                                                         ?IDX-POSITION ROT                                               3 PICK IDX.HASH PERFORM                                         R> <add-node> ;                                                                                                    : IDX-DEL    ( icb item# --- )                                               OVER SWAP <raw-find>                                            DUP -1 <> IF 2DUP <del-node>                                              THEN 2DROP ;                                                                                             : IDX-UPD    ( icb buff item# --- )                                          2 PICK OVER IDX-DEL                                             IDX-ADD ;                                          \ IDX-HEAD                                                                                                                                                                                      : IDX-HEAD    ( icb --- #node or -1 for none )                                -1 OVER ?nodes                                                   0 ?DO                                                               OVER INODE I <read-node> DROP                                   INODE N.FLAG C@ 0=                                              IF INODE N.LST-LINK @                                              -1 = IF DROP INODE N.LST-LINK OVER                                      IDX.LAST 4 CMOVE INODE N.WHOAMI @                               OVER OVER SWAP IDX.ME !                                         LEAVE THEN THEN                                     LOOP                                                         NIP ;                                                                                                            \ IDX-NEXT & IDX-LAST                                                                                                           : IDX-NEXT ( icb --- #item or -1 for no more )                             DUP IDX.ME @ -1 = IF IDX-HEAD EXIT THEN                         DUP IDX.NEXT @ DUP -1 <>                                        IF >R DUP INODE R> <read-node> DROP                                INODE N.LST-LINK OVER IDX.LAST 4 CMOVE                          INODE N.WHOAMI @ OVER OVER SWAP IDX.ME !                     THEN NIP ;                                                                                                           : IDX-LAST ( icb --- #item or -1 for no more )                             DUP IDX.LAST @ DUP -1 <>                                        IF >R DUP INODE R> <read-node> DROP                                INODE N.LST-LINK OVER IDX.LAST 4 CMOVE                          INODE N.WHOAMI @ OVER OVER SWAP IDX.ME !                     THEN NIP ;                                           \ <?equal>                                       10:40 02/16/88                                                                 : <?equal>  ( icb item_buff str-#item  --- #item or -1 none )               BEGIN                                                              >R 2DUP R>                                                      <compare> 0= IF 2DROP INODE N.WHOAMI @ EXIT                                  THEN                                               INODE N.NXT-HASH @ -1 = IF 2DROP -1 EXIT THEN                   OVER INODE INODE N.NXT-HASH @ <read-node> DROP                  INODE N.WHOAMI @                                             AGAIN                                                           ;                                                                                                                                                                                                                                                                                                                   \ IDX-FIND                                       10:16 02/15/88                                                                 : IDX-FIND  ( icb item_buff --- #item of -1 for not found )                 OVER OVER SWAP IDX.HASH PERFORM >R                              OVER R> 2* S>D 0 FSEEK 2DROP                                    OVER I-NEXT 2 FREAD DROP I-NEXT @ DUP                           -1 = IF 3DROP -1 EXIT THEN                                      >R OVER INODE R> <read-node> DROP                               OVER INODE N.NXT-LINK SWAP IDX.LAST 4 CMOVE                     INODE N.WHOAMI @                                                <?equal> ;                                                                                                                                                                                                                                                                                                                                                                          \ di-open & di-close                             09:41 03/16/88                                                                                                                                 : DI-OPEN     ( cb --- )                                                      DUP ?TYPE IF 2 FOPEN DROP ELSE OPEN-DICTIONARY                            THEN ;                                                                                                                                                                  : DI-CLOSE   ( cb --- )                                                      DUP ?TYPE IF FCLOSE DROP ELSE CLOSE-DICTIONARY                            THEN ;                                                                                                                                                                                                                                                                                                                                                                   \ Dictionary Choose                              09:27 02/19/88 \S                                                                  This section defines the dictionary and index choose words.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 ( dictionary choice def.                       09:28 09/29/87 )                                                                 ( choice structure -- addr )                                    : CH.LEN       C@ ;            \ length of string display       : CH.OFF   1 +  @ ;            \ offset in buffer for display   : CH.BADDR 3 +  @ ;            \ buffer addr                    : ch.daddr 5 +  @ ;            \ dictionary address             : CH.COND  7 +  @ ;            \ condition                      : CH.FMT   9 +  @ ;            \ advanced format display        : CH.INP   11 + @ ;            \ input vector                   : CH.INS   13 + @ ;            \ insert key vector              : CH.DEL   15 + @ ;            \ delete key vector                                                                              : CH.DADDR ( cb --- addr )                                                 ch.daddr DUP ?TYPE IF IDX.DCB THEN ;                                                                                 ( no.fmt                                       09:05 09/29/87 )                                                                 ( choice -- len saddr )                                         : NO.FMT      DUP CH.BADDR                 \ get buffer addr                  SWAP DUP CH.OFF ROT + SWAP   \ get addr in buffer               CH.LEN SWAP ;                \ show it                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            ( Dictionary Choice                            10:28 09/12/87 )                                                                 : DCT-CHOICE  CREATE C, , , , ,                                                      DEPTH 0=                                                        IF ['] PCKEY ['] NO.FMT THEN  \ key & fmt                       , ,                                                             DEPTH 0=                                                        IF ['] NOOP ['] NOOP THEN     \ ins & del                       , , DOES>  ;                                                                                                                                                                                                                                                                                               : NO.COND  -1     ;            \ no conditions                                                                                                                                                  ( dct-next                                     17:11 07/09/87 )                                                                 ( cond. buff dct -- 0 for more items, -1 for no more items )    : dct-next  DUP D.LST-READ @ ROT ROT                                        BEGIN                                                              DUP D.LST-READ @ OVER D.HU @ 1- <                               WHILE                                                            OVER OVER DUP D.LST-READ @ 1+ SWAP DICT-READ                    OVER C@ 0= IF 3 PICK EXECUTE                                                  IF                                                                2DROP 2DROP 0 EXIT                                            THEN                                                         THEN                                             REPEAT                                                          ROT SWAP DICT-READ DROP -1 ;                                                                                        \ @last                                          10:16 03/14/88                                                                 : @last    ( last buff idx --- )                                           ROT OVER SWAP INODE SWAP                                        <read-node> DROP INODE N.LST-LINK OVER IDX.LAST 4               CMOVE INODE N.WHOAMI @ OVER IDX.ME !                            DUP IDX.ME @ SWAP IDX.DCB DICT-READ ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ idx-next                                   hs  13:25 02/18/88                                                                                                                                 : idx-next  ( cond. buff idx --- 0/more,-1/nomore )                         I-LAST @ SWAP >R SWAP >R SWAP R> R>                             BEGIN                                                             DUP IDX-NEXT -1 = IF ROT DROP @last -1 EXIT THEN                2DUP DUP IDX.ME @ SWAP IDX.DCB DICT-READ                        2 PICK EXECUTE                                                UNTIL 4DROP 0 ;                                                                                                     : NXT-ITEM  ( cond. buff cb --- 0/more,-1/nomore )                          DUP ?TYPE IF idx-next ELSE dct-next THEN ;                                                                                                                                                                                                          \ dct-last                                       13:11 02/18/88                                                                 ( cond. buff dct -- )                                           : dct-last  DUP D.LST-READ @ ROT ROT                                        BEGIN                                                              DUP D.LST-READ @ 1 >=                                           WHILE                                                            OVER OVER DUP D.LST-READ @ 1- SWAP DICT-READ                    OVER C@ 0= IF 3 PICK EXECUTE                                                  IF                                                                2DROP 2DROP 0 EXIT                                            THEN                                                         THEN                                             REPEAT                                                          ROT SWAP DICT-READ DROP -1 ;                                                                                        \ idx-last                                   hs  13:14 02/18/88                                                                 : idx-last  ( cond. buff idx --- 0/more,-1/nomore )                         I-LAST @ SWAP >R SWAP >R SWAP R> R>                             BEGIN                                                             DUP IDX-LAST -1 = IF ROT DROP @last -1 EXIT THEN                2DUP DUP IDX.ME @ SWAP IDX.DCB DICT-READ                        2 PICK EXECUTE                                                UNTIL 4DROP 0 ;                                                                                                                                                                     : LST-ITEM  ( cond. buff cb --- 0/more,-1/nomore )                          DUP ?TYPE IF idx-last ELSE dct-last THEN ;                                                                                                                                                                                                          ( .item                                        15:31 07/21/87 )                                                                 ( attr window choices lne -- )                                  : .ITEM       SWAP >R OVER >R SWND-POS   \ get screen coor                    ROT R> SWAP                                                     R> DUP CH.FMT EXECUTE      \ do formatting                      WND-STR!                   \ get buffer addr                    ;                                                                                                                 ( dict-choice -- cond buff dictionary )                         : CH->FOO   DUP CH.COND SWAP DUP CH.BADDR SWAP ch.daddr ;                                                                                                                                                                                                                                                                                                                                       \ dct-fill                                   hs  13:30 02/18/88                                                                 ( window choices -- )                                           : DCT-FILL  DUP CH.DADDR OVER ch.daddr                                      ?TYPE IF OVER ch.daddr IDX.ME -1 SWAP ! THEN                    -1 SWAP D.LST-READ !       \ set to first record                OVER WINDOW-#ROW C@ 1-     \ get number of rows                 OVER CH.DADDR D.HU @       \ number of choices                  OVER OVER >= IF SWAP DROP                                                    ELSE DROP                                                       THEN                                               0 DO DUP CH->FOO NXT-ITEM                                            IF LEAVE THEN                                                   NOR 2 PICK 2 PICK I 1+ .ITEM LOOP                          DROP DROP ;                                                                                                         ( dct-fst                                      15:31 07/21/87 )                                                                                                                                 : DCT-FST   OVER ch.daddr ?TYPE IF OVER ch.daddr IDX.LAST @ -1              <> ELSE OVER CH.DADDR D.LST-READ @ 0<> THEN                        IF                                                               NOR 3 PICK 3 PICK 3 PICK .ITEM                                  OVER CH->FOO LST-ITEM                                           NOT IF 2 PICK WND-DOWN                                              ELSE 100 15 BEEP THEN                                       LTB 3 PICK 3 PICK 3 PICK .ITEM                                 ELSE                                                             100 15 BEEP EXIT                                               THEN ;                                                                                                                                                                           ( dct-up                                       15:31 07/21/87 )                                                                 : DCT-UP ( window choice lne -- window choices lne-1 )                   OVER CH.DADDR D.NA @ IF                                         DUP 3 PICK SWAP                                                 TL? IF DCT-FST                                                      ELSE                                                               NOR 3 PICK 3 PICK 3 PICK .ITEM                                  OVER CH->FOO LST-ITEM                                           0= IF 1-                                                           ELSE 100 15 BEEP THEN                                        LTB 3 PICK 3 PICK 3 PICK .ITEM                               THEN THEN ;                                                                                                                                                                                                                                        ( dct-lst                                      14:54 07/13/87 )                                                                 ( window choice lne )                                           : DCT-LST   OVER ch.daddr ?TYPE IF OVER ch.daddr IDX.LAST @ -1              <> ELSE                                                         OVER CH.DADDR DUP D.LST-READ @ 1+ SWAP D.HU @ < THEN             IF                                                                 NOR 3 PICK 3 PICK 3 PICK .ITEM                                  OVER CH->FOO NXT-ITEM                                           NOT IF 2 PICK WND-UP                                                ELSE 100 15 BEEP THEN                                       LTB 3 PICK 3 PICK 3 PICK .ITEM                                 ELSE                                                             100 15 BEEP EXIT                                               THEN ;                                                                                                           ( dct-dw                                       15:31 07/21/87 )                                                                 : DCT-DW ( window choice lne -- window choices lne-1 )                   OVER CH.DADDR D.NA @ IF                                         DUP 3 PICK SWAP                                                 BL? IF DCT-LST                                                      ELSE                                                               NOR 3 PICK 3 PICK 3 PICK .ITEM                                  OVER CH->FOO NXT-ITEM                                           0= IF 1+                                                           ELSE 100 15 BEEP THEN                                        LTB 3 PICK 3 PICK 3 PICK .ITEM                               THEN THEN ;                                                                                                                                                                                                                                        ( dct-pgup                                     14:31 07/20/87 )                                                                                                                                 : DCT-PGUP ( wcb dccb lne -- wcb dccb lne )                                OVER CH.DADDR D.NA @ IF                                         2 PICK WINDOW-#ROW C@ 2- 0                                      ?DO                                                                DCT-UP                                                          OVER CH->FOO LST-ITEM                                           IF 100 15 BEEP LEAVE THEN                                       OVER CH->FOO NXT-ITEM DROP                                   LOOP                                                            THEN ;                                                                                                                                                                                                                                               ( dct-pgdw                                     15:31 07/21/87 )                                                                                                                                 : DCT-PGDW  ( wcb dccb lne -- wcb dccb lne )                                OVER CH.DADDR D.NA @ IF                                         2 PICK WINDOW-#ROW C@ 2- 0                                      ?DO                                                               DCT-DW                                                          OVER CH->FOO NXT-ITEM                                           IF 100 15 BEEP LEAVE THEN                                       OVER CH->FOO LST-ITEM DROP                                    LOOP                                                            THEN ;                                                                                                                                                                                                                                              \ dct-disp-reset                             hs  08:30 01/14/88                                                                 ( wcb dcb -- )                                                  : DCT-DISP-RESET   OVER DUP WND-CLR OVER DCT-FILL                                  -1 OVER CH.DADDR D.LST-READ !                                   DUP ch.daddr ?TYPE                                              IF DUP ch.daddr IDX.ME -1 SWAP ! THEN                           DUP CH->FOO NXT-ITEM DROP                                       LTB ROT ROT 1 .ITEM ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        \ dct-setup                                  hs  08:31 01/14/88                                                                 ( wcb dcb --  wcb dcb choice )                                  : DCT-SETUP   DUP CH.DADDR D.NA @                                             IF                                                                OVER OVER DCT-DISP-RESET 1                                    ELSE                                                              DUP CH.LEN >R                                                   OVER DUP >R 1 SWND-POS R> HIL                                   " No Items to select" COUNT R> MIN SWAP                         WND-STR! 1                                                    THEN ;                                                                                                                                                                                                                                                                                                            ( dct-choose                                   15:30 07/21/87 )                                                                 : DCT-CHOOSE ( window chooses -- rec+1, 0 for escape )                       DCT-SETUP BEGIN OVER CH.INP EXECUTE ?DUP DROP                   CASE                                                             01 OF LTB 3 PICK 3 PICK 3 PICK .ITEM  ENDOF                     72 OF DCT-UP              ENDOF                                 73 OF DCT-PGUP            ENDOF                                 80 OF DCT-DW              ENDOF                                 81 OF DCT-PGDW            ENDOF                                 82 OF OVER CH.INS EXECUTE ENDOF                                 83 OF OVER CH.DEL EXECUTE ENDOF                                 13 OF ROT 2DROP CH.DADDR DUP D.NA @ IF D.LST-READ                     @ 1+ ELSE DROP 0 THEN EXIT ENDOF                          27 OF 2DROP DROP 0 EXIT ENDOF                                  ENDCASE AGAIN ;