Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ A simple immplementation of the blocks wordset. |
| 2 : | |||
| 3 : | \ This implementation uses only a single buffer and will therefore be a | ||
| 4 : | \ little slow. An efficient implementation would use mmap on OSs that | ||
| 5 : | \ provide it and many buffers on OSs that do not provide mmap. | ||
| 6 : | |||
| 7 : | \ I think I avoid the assumption 1 char = 1 here, but I have not tested this | ||
| 8 : | |||
| 9 : | pazsan | 1.2 | \ 1024 constant chars/block \ mandated by the standard |
| 10 : | anton | 1.1 | |
| 11 : | create block-buffer chars/block chars allot | ||
| 12 : | |||
| 13 : | variable buffer-block 0 buffer-block ! \ the block currently in the buffer | ||
| 14 : | variable block-fid 0 block-fid ! \ the file id of the current block file | ||
| 15 : | variable buffer-dirty buffer-dirty off | ||
| 16 : | |||
| 17 : | |||
| 18 : | : get-block-fid ( -- fid ) | ||
| 19 : | block-fid @ 0= | ||
| 20 : | if | ||
| 21 : | s" blocks.fb" r/w open-file 0<> | ||
| 22 : | if | ||
| 23 : | s" blocks.fb" r/w create-file .s throw | ||
| 24 : | then | ||
| 25 : | block-fid ! | ||
| 26 : | then | ||
| 27 : | block-fid @ ; | ||
| 28 : | |||
| 29 : | : block-position ( u -- ) | ||
| 30 : | \ positions the block file to the start of block u | ||
| 31 : | 1- chars/block chars um* get-block-fid reposition-file .s throw ; | ||
| 32 : | |||
| 33 : | : update ( -- ) | ||
| 34 : | buffer-dirty on ; | ||
| 35 : | |||
| 36 : | : save-buffers ( -- ) | ||
| 37 : | buffer-dirty @ | ||
| 38 : | if | ||
| 39 : | buffer-block @ block-position | ||
| 40 : | block-buffer chars/block get-block-fid write-file throw | ||
| 41 : | buffer-dirty off | ||
| 42 : | endif ; | ||
| 43 : | |||
| 44 : | : empty-buffers ( -- ) | ||
| 45 : | 0 buffer-block ! ; | ||
| 46 : | |||
| 47 : | : flush ( -- ) | ||
| 48 : | save-buffers | ||
| 49 : | empty-buffers ; | ||
| 50 : | |||
| 51 : | : block ( u -- a-addr ) | ||
| 52 : | dup 0= -35 and throw | ||
| 53 : | dup buffer-block @ <> | ||
| 54 : | if | ||
| 55 : | save-buffers | ||
| 56 : | dup block-position | ||
| 57 : | block-buffer chars/block get-block-fid read-file .s throw | ||
| 58 : | \ clear the rest of the buffer if the file is too short | ||
| 59 : | block-buffer over chars + chars/block rot - blank | ||
| 60 : | buffer-block ! | ||
| 61 : | else | ||
| 62 : | drop | ||
| 63 : | then | ||
| 64 : | block-buffer ; | ||
| 65 : | |||
| 66 : | : buffer ( u -- a-addr ) | ||
| 67 : | \ reading in the block is unnecessary, but simpler | ||
| 68 : | block ; | ||
| 69 : | |||
| 70 : | pazsan | 1.2 | User scr 0 scr ! |
| 71 : | anton | 1.1 | |
| 72 : | : list ( u -- ) | ||
| 73 : | \ calling block again and again looks inefficient but is necessary | ||
| 74 : | \ in a multitasking environment | ||
| 75 : | dup scr ! | ||
| 76 : | ." Screen " u. cr | ||
| 77 : | 16 0 | ||
| 78 : | ?do | ||
| 79 : | scr @ block i 64 * chars + 64 type cr | ||
| 80 : | loop ; | ||
| 81 : | |||
| 82 : | pazsan | 1.2 | : (source) ( -- addr len ) |
| 83 : | blk @ ?dup | ||
| 84 : | IF block chars/block | ||
| 85 : | ELSE tib #tib @ | ||
| 86 : | THEN ; | ||
| 87 : | |||
| 88 : | ' (source) IS source | ||
| 89 : | |||
| 90 : | : load ( i*x n -- j*x ) | ||
| 91 : | push-file | ||
| 92 : | dup loadline ! blk ! >in off ( ['] ) interpret ( catch ) | ||
| 93 : | pop-file ( throw ) ; | ||
| 94 : | anton | 1.1 | |
| 95 : | pazsan | 1.2 | : thru ( i*x n1 n2 -- j*x ) |
| 96 : | 1+ swap 0 ?DO I load LOOP ; | ||
| 97 : | anton | 1.1 | |
| 98 : | pazsan | 1.2 | : +load ( i*x n -- j*x ) blk @ + load ; |
| 99 : | |||
| 100 : | : +thru ( i*x n1 n2 -- j*x ) | ||
| 101 : | 1+ swap 0 ?DO I +load LOOP ; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |