Power-Programmierung/CD1.mdf/forth/rbsrc/rb-root.scr

Text File | 1988-05-03 | 10KB | 1 lines

\ RazorBack Root                                  17:37 05/03/88                                                                                                                                    This contains the RazorBack root system code.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               \ System Block                                   09:56 03/07/88                                                                 HCB SYS.BLK    " RBDB.CNF" SYS.BLK NAME>HCB                                                                                     CREATE SYS.BLOCK    256 ALLOT           \ system code                                                                           1005 CONSTANT SERIES                                                                                                            512 CONSTANT MAX_REC_SZ           ( maximum size for a record )                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \ lcmain definitions                             10:29 04/11/88                                                                 BEGIN-ITEM LC-FILE                                                       1 LC-FILE LC.FLG                                               30 LC-FILE LC.DESCR                                              8 LC-FILE LC.FNAME                                             25 LC-FILE LC.FREE                                      END-ITEM                                                                                                                                                                                        DICTIONARY LCMAIN.DCT MASTER                                                                                                                                                                                                                                                                                                                                                                    \ system-init                                    10:29 04/11/88                                                                                                                                 : SYSTEM-INIT  ( --- )                                                         LCMAIN.DCT HCB>H 0=                                             IF LCMAIN.DCT OPEN-DICTIONARY THEN                              SYS.BLK 2 FOPEN DROP                                            SYS.BLK SYS.BLOCK 256 FREAD DROP                                SYS.BLK FCLOSE DROP ;                                                                                                                                                            : ALARM    ( --- )                                                         10 0 DO 500 10 BEEP 750 10 BEEP LOOP ;                                                                                                                                                                                                               \ system block layout                            09:59 03/07/88                                                                 VARIABLE SERIAL#      3 SERIAL# !                                                                                               : SYS.DATA    SYS.BLOCK             ;      \ data path          : SYS.STATE   SYS.BLOCK  30  +      ;      \ default state      : SYS.CNTL    SYS.BLOCK  32  +      ;      \ 2 byte bits                                                                        : ?CASE       ( --- t/f )             \ searches case sensitive               SYS.CNTL @ 0 @BIT ;                                                                                               : ?DEL        ( --- t/f )             \ confirm all deletions                 SYS.CNTL @ 1 @BIT ;                                                                                                                                                                                                                               \ help & @form                                   09:47 03/08/88                                                                 : HELP      ( help# --- )                                                   " RBHELP" BRUN RBHELP                                           FORGET OVERLAY ;                                                                                                    : @FORM     ( file# --- )                                                   " RB@FORM" BRUN RB@FORM                                         FORGET OVERLAY ;                                                                                                    : .VIEW     ( file# --- )                                                   " RBVIEW" BRUN RBVIEW                                           FORGET OVERLAY ;                                                                                                                                                                                                                                    \ overlay                                        16:00 04/13/88                                                                 : FORM-MAINT   " RBMAINT" BRUN RBMAINT                                         FORGET OVERLAY ;                                                                                                 : REPORTS      ( file# --- )                                                   " RBREPT" BRUN RBREPT                                           FORGET OVERLAY  ;                                                                                                                                                                : EDT-VIEW     " RBEVIEW" BRUN RBEVIEW                                         FORGET OVERLAY  ;                                                                                                                                                                                                                                                                                                \ Overlays                                       17:17 04/13/88                                                                                                                                 : EDT-REPORTS  " RBEREPT" BRUN RBEREPT                                         FORGET OVERLAY ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \ numcmp                                         20:08 04/13/88                                                                                                                                 : NUMCMP   ( d1 d2 --- flag )                                              2OVER 2OVER D= IF 4DROP 0  EXIT THEN                            2OVER 2OVER D< IF 4DROP -1 EXIT THEN                            D> IF 1 THEN ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       \ obox                                           21:09 04/13/88                                                                 : OBOX     0  0 FULLW NOR 201 WND-CHAR!                                   79  0 FULLW NOR 187 WND-CHAR!                                    0 23 FULLW NOR 200 WND-CHAR!                                   79 23 FULLW NOR 188 WND-CHAR!                                   23 1 ?DO 0 I FULLW NOR 186 WND-CHAR!                                    79 I FULLW NOR 186 WND-CHAR! LOOP                       79 1 ?DO I 0 FULLW NOR 205 WND-CHAR!                                     I 23 FULLW NOR 205 WND-CHAR! LOOP ;