home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / status.seq < prev    next >
Text File  |  1990-07-09  |  3KB  |  68 lines
  1. \ STATUS.SEQ    Display a status line at screen top.    by Tom Zimmer
  2.  
  3. 0 value vocv    \ show vocabulary stack value flag
  4.  
  5. : <.STAT>       ( --- )
  6.                 printing @ ?exit        \ NO status if printing
  7.                 savecursor
  8.                 base @ >r decimal
  9.                 0 0 at >attrib1
  10.                 ."  C - " sp@ here - 0 1000 um/mod nip (u.) type ." k : - "
  11.                 #listsegs xhere drop xseg @ - - 16 *d
  12.                 1000 um/mod nip (u.) type ." k"
  13.                 2 spaces depth
  14.                 if      >attrib4 ."  Depth " depth (u.) dup>r type
  15.                         4 r> - spaces >attrib1
  16.                 else    ." Stack Empty"
  17.                 then    2 spaces seqhandle >hndle @ -1 =
  18.                 if      seqhandle dup clr-hcb pathset drop
  19.                         -2 seqhandle >hndle !
  20.                 then    .seqhandle cols #out @ - spaces
  21.                 vocv                            \ if vocabulary showing is on
  22.                 if      cols 11 - 1 at >attrib3
  23.                         current @ body> >name space %.id eeol
  24.                         >attrib1
  25.                         #vocs 1- context over 0
  26.                         do      dup @ ?dup 0= if nip i swap leave then
  27.                                 cols 11 - i 2+ at
  28.                                 body> >name space %.id eeol 2+
  29.                         loop    drop
  30.                         cols 11 - over 2+ at space
  31.                         ['] root >name %.id eeol >norm
  32.                         1+ #vocs over - bounds over min
  33.                         ?do     cols 11 - i 2+ at 11 spaces
  34.                         loop
  35.                 then    >attrib1
  36.                 cols 7 - 0 at space
  37.                 dtbuf off
  38.                 gettime drop build-hm dtbuf count type space >norm
  39.                 r> base !
  40.                 restcursor ;
  41.  
  42. : .STATUS       ( -- )
  43.                 defers status
  44.                 ?stack
  45.                 statv @
  46.                 if      <.stat>
  47.                 then    ;
  48.  
  49. ' .STATUS IS STATUS             \ Status printed for command lines.
  50. ' <.STAT> IS LOADSTAT           \ Status printed while loading.
  51.  
  52. : STATON        ( --- )
  53.                 STATV ON ;
  54.  
  55. : STATOFF       ( --- )
  56.                 STATV OFF ;
  57.  
  58. STATON          \ default to displaying status line
  59.  
  60. : VOCON         ( -- )
  61.                 ON> VOCV ;
  62.  
  63. : VOCOFF        ( -- )
  64.                 OFF> VOCV ;
  65.  
  66. VOCON           \ default to displaying the vocabulary stack
  67.  
  68.