home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / allspecs.seq < prev    next >
Text File  |  1990-10-27  |  2KB  |  71 lines
  1. \ ALLSPECS.SEQ      Return all directories one at a time
  2.  
  3. 4000 constant dirlenmax
  4.        create dirlist dirlenmax 100 + allot
  5.       0 value dirlistlen
  6.       0 value dirptr
  7.   16 constant dirattribute
  8.        handle dirshndl
  9.        handle curhndl
  10.        create startdir ," \" 64 allot
  11.  
  12. create dirpad 1024 allot
  13.  
  14. : nullcmove     ( a1 a2 -- n1 )
  15.                 over 64 2dup 0 scan nip - dup>r nip cmove r> ;
  16.  
  17. : dir>list      ( a1 -- )       \ append a dir spec to list
  18.                 dirlistlen dirlenmax <
  19.                 if      dirlist dirlistlen + >r
  20.                         curhndl count 3 - 0max r@ place
  21.                         r@ count + nullcmove r@ c+!
  22.                         r> c@ 1+ +!> dirlistlen
  23.                 else    drop
  24.                 then    ;
  25.  
  26. : nulltype      ( a1 -- )
  27.                 12 2dup 0 scan nip - type space ?cr ;
  28.  
  29. : +place        ( a1 n1 a2 -- )         \ append a1 n1 to counted a2
  30.                 dup>r count + over r> c+! swap cmove ;
  31.  
  32. : $getdirs      ( a1 --- )
  33.                 dirshndl $>handle         \ get directory spec
  34.                 dirpad SET-DTA
  35.                 dirshndl >nam findfirst
  36.                 begin   255 and 0=
  37.                 while   dirpad 21 + c@ dirattribute =
  38.                         dirpad 30 + c@ '.' <> and
  39.                         if      dirpad 30 + dir>list
  40.                         then    findnext
  41.                 repeat  ;
  42.  
  43. long_branch
  44.  
  45. : getdirs       ( -- )
  46.                 dirlist dirlenmax 100 + erase
  47.                 startdir count dup 1+ =: dirlistlen dirlist place
  48.                 dirlist
  49.                 begin   dup c@
  50.                         ?keypause
  51.                 while             curhndl clr-hcb
  52.                         dup count curhndl place
  53.                                   curhndl count + 1- c@ '\' <>
  54.                         if  " \"  curhndl +place
  55.                         then
  56.                         " *.*"    curhndl +place
  57. \                                  curhndl count cr type space
  58.                                   curhndl $getdirs
  59.                         count +
  60.                 repeat  drop dirlist =: dirptr ;
  61.  
  62. short_branch
  63.  
  64. : nextdir       ( -- a1 )
  65.                 dirptr dup count dup
  66.                 if      + =: dirptr
  67.                 else    2drop
  68.                 then    ;
  69.  
  70.  
  71.