home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFB.ZIP / FFUTILS.ARC / ZIMMER.ARC / BLOCKS.SEQ < prev    next >
Encoding:
Text File  |  1987-12-27  |  3.8 KB  |  145 lines
  1. \ BLOCKS.SEQ      Blocks support for FF                 by Tom Zimmer
  2.  
  3.  1024 constant b/buf
  4.    64 constant c/l
  5.       variable updated
  6.       variable blk
  7.       variable scr
  8.  
  9. create block_buffer     b/buf allot
  10.  
  11. : empty-buffers ( -- )
  12.                 block_buffer b/buf erase ;
  13.  
  14. : set_offset    ( --- )
  15.                 blk @ b/buf um* shndl @ movepointer ;
  16.  
  17. : save-buffers  ( -- )
  18.                 updated @
  19.                 if      set_offset
  20.                         block_buffer b/buf shndl @ hwrite drop
  21.                         updated off
  22.                 then    ;
  23.  
  24. : flush         ( -- )
  25.                 save-buffers  empty-buffers  ;
  26.  
  27. : capacity      ( -- n )
  28.                 shndl @ endfile b/buf um/mod nip ;
  29.  
  30. : update        ( -- )   updated on ;
  31.  
  32. : discard       ( -- )   updated off ;
  33.  
  34. : buffer        ( n -- a )
  35.                 save-buffers
  36.                 blk !
  37.                 block_buffer ;
  38.  
  39. : block         ( n1 --- a1 )
  40.                 blk @ over =
  41.                 if      drop
  42.                 else    save-buffers
  43.                         blk !
  44.                         set_offset
  45.                         block_buffer b/buf shndl @ hread b/buf - disk-error !
  46.                 then    block_buffer ;
  47.  
  48. : ?BLOCKFILE    ( --- F1 )
  49.                 SHNDL @ HANDLE>EXT " .BLK" CAPS-COMP 0= ;
  50.  
  51. : BLOCK_LOAD    ( n -- )
  52.                 DUP  BLOCK
  53.                 'TIB DUP @ >R !
  54.                 BLK  DUP @ >R !
  55.                 >IN  DUP @ >R OFF
  56.                 B/BUF DUP SPAN DUP @ >R ! #TIB !
  57.                 RUN
  58.                 R> DUP SPAN ! #TIB !
  59.                 R> >IN !
  60.                 R> BLK !
  61.                 R> 'TIB ! ;
  62.  
  63. : thru          ( N1 N2 --- )
  64.                 1+ swap over min
  65.                 ?do     i block_load
  66.                 loop    ;
  67.  
  68. warning dup @ swap off          \ save warning for later, but OFF for now.
  69.  
  70. : load          ( n1 --- )
  71.                 ?blockfile
  72.                 if      block_load
  73.                 else    load
  74.                 then    ;
  75.  
  76. : loadall       ( N1 --- )
  77.                 capacity 2/ 1- thru ;
  78.  
  79.                 \ Must NOT use any \ type comments following this next
  80.                 \ definition in this file.
  81.  
  82. : \             ( --- )
  83.                 ?blockfile
  84.                 if      >in @ negate c/l mod >in +!
  85.                 else    \
  86.                 then    ; immediate
  87.  
  88. : \s            ( --- )
  89.                 ?blockfile
  90.                 if      end? on
  91.                 else    \s
  92.                 then    ;
  93.  
  94. : (s            ( --- )
  95.                 [compile] ( ; immediate
  96.  
  97. : ok            ( --- )
  98.                 ?blockfile
  99.                 if      1 block_load
  100.                 else    ok
  101.                 then    ;
  102.  
  103. : ed            ( --- )
  104.         ?blockfile abort" Mustn't edit BLOCK files, use BLKTOSEQ first."
  105.                 ed ;
  106.  
  107. : edit          ( n1 --- )
  108.         ?blockfile abort" Mustn't edit BLOCK files, use BLKTOSEQ first."
  109.                 edit ;
  110.  
  111. : block_list    ( n1 --- )
  112.                 dark cr
  113.                 dup scr ! cr ." Screen " dup . ." of " .file
  114.                 block 16 0
  115.                 do      cr i 3 .r space
  116.                         i c/l * over + c/l -trailing type
  117.                 loop    cr drop ;
  118.  
  119. : list          ( n1 --- )
  120.                 ?blockfile
  121.                 if      block_list
  122.                 else    list
  123.                 then    ;
  124.  
  125. : l             ( --- )
  126.                 ?blockfile
  127.                 if      scr @ list
  128.                 else    l
  129.                 then    ;
  130.  
  131. : n             ( --- )
  132.                 ?blockfile
  133.                 if      scr @ 1+ capacity 1- min list
  134.                 else    n
  135.                 then    ;
  136.  
  137. : b             ( --- )
  138.                 ?blockfile
  139.                 if      scr @ 1- 0 max list
  140.                 else    b
  141.                 then    ;
  142.  
  143. warning !
  144.  
  145.