home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / forst / util.s < prev    next >
Encoding:
Text File  |  1993-10-23  |  6.6 KB  |  268 lines
  1. ( UTIL.S:  ForST additional words 18/7/89)
  2.  
  3. decimal macros cr
  4.  
  5. 32 constant bl
  6.  
  7. : .(  41 word count type ; immediate
  8. : \  10 upto drop ; immediate
  9.  
  10. : .r  >r dup >r <# #s r> sign #> r>  over - spaces  type ;
  11. : u.r  >r  <# #s #>  r>  over - spaces  type ;
  12. : type.r  over - spaces  type ;
  13.  
  14. .( keyboard utilities) cr
  15.  
  16. : save2  d2 a7 dec ! a2 a7 dec ! ; ( might be bashed!)
  17. : retrieve2  a7 inc @ to a2  a7 inc @ to d2 ;
  18.  
  19. : key? ( has a key been pressed?)
  20.   save2  11 a7 dec w! gemdos
  21.   d0 a6 dec w!  0 a6 dec w! ( extend flag to long word)
  22.   2 addto a7  retrieve2 ;
  23.   
  24. : wait  key drop ;
  25.  
  26. : ?key  ( --t/f) key?  dup if drop wait key 27 = then ;
  27.  
  28. .( words using cfa: >name, >code, >body ) cr
  29.  
  30. : >name  5 - -1 traverse ;
  31. : >code  @ os> ;
  32. : >body  4+ @ os> ;
  33.  
  34. .( words using nfa: name>, id., words, macwords) cr
  35.  
  36. : name>  1 traverse 5 + ;
  37.  
  38. : id.  { 1 regarg ptr  2 regs padding chars }
  39.   ptr inc c@ 31 and to chars  13 chars - to padding
  40.   for chars  ptr inc c@  127 and emit  next
  41.   padding spaces ;
  42.  
  43. : words  { 3 regs headptr #words column }
  44.   cr  0 to #words  0 to column  there to headptr
  45.   begin
  46.    headptr dec w@  dup
  47.    negate addto headptr ( ^new head)
  48.    headptr  id.  1 addto #words  1 addto column
  49.    column 6 =  if cr 0 to column then
  50.    0= ?key  or
  51.   until
  52.   cr  #words . ." words displayed" ;
  53.  
  54. : macwords  { 3 regs headptr #words column }
  55.   cr  0 to #words  0 to column  there to headptr
  56.   begin
  57.    headptr dec w@  dup
  58.    negate addto headptr ( ^new head)
  59.    headptr 1 traverse 3 + c@
  60.    if ( a macro)
  61.      headptr  id.  1 addto #words  1 addto column
  62.      column 6 =  if cr 0 to column then
  63.    then
  64.    0= ?key or
  65.   until
  66.   cr  #words . ." macros displayed" ;
  67.  
  68. .( extension utilities ) cr
  69.  
  70. : <> = not ;
  71. : flag  0= not ;
  72.  
  73. : islower  dup 96 > swap 123 < and ;
  74. : isupper  dup 64 > swap 91 < and ;
  75. : upper  bl - ;
  76. : lower  bl + ;
  77.  
  78. : blank  bl fill ;
  79. : erase  0 fill ;
  80.  
  81. : ascii  bl word 1+ c@ ;
  82. : [ascii]  ascii [compile] literal ; immediate
  83. : integer  bl word inumber
  84.   state @  if [compile] literal then ; immediate
  85.   
  86. .( disk utilities) cr    
  87.  
  88. : namearg  bl word  0 over count + c!  1+ ;
  89.  
  90. : setdrive  setdrv drop ;
  91. : a: 0 setdrive ;
  92. : b: 1 setdrive ;
  93. : c: 2 setdrive ;
  94. : d: 3 setdrive ;
  95. : e: 4 setdrive ;
  96.  
  97. : cd  namearg chdir  0< if ." cannot set up path " then ;
  98.  
  99. : utilities ;
  100.  
  101. .( utilities with direct file i/o: dump, blksave) cr
  102.  
  103. : .hex  <# # # #> type space ;
  104. : .addr  cr <# [ascii] : hold # # # # # #  #> type space space ;
  105. : .bytes  0 do count .hex   i 7 =   if space then   loop   drop ;
  106. : .char  dup bl < if drop [ascii] . then emit ;
  107. : .chars  0 do count .char loop   drop ;
  108. : dline  ( --addr,n)  over over .bytes  space space  .chars ;
  109. : dump  namearg  0 open   cls base @ >r hex   0
  110.    begin   dup .addr 16 +  over pad 16 read
  111.    pad over dline   16 = not ?key or  until
  112.    drop close  r> base ! ;
  113.  
  114. : blksave  namearg 0 fmake  dup >r
  115.    swap write  r> close ;
  116.  
  117. .( memory utilities: <address> mdump,  <addr> dp,  wd <wordname> ) cr
  118.  
  119. : mdump  ( --addr)
  120.   cr  even  base @ >r hex
  121.   begin  dup .addr  dup 16 dline  16 +  ?key until
  122.   r> base !  drop ;
  123.   
  124. : .hex <# # # # # #> type space ;
  125.  
  126. : dp  { 1 regarg pointer 1 reg sofar }
  127.   0 to sofar  base @ >r hex  cr
  128.   begin
  129.    pointer inc w@ .hex
  130.    2 addto sofar
  131.   key 27 = until
  132.   cr  sofar . ." bytes and "  pointer . ." is next address"
  133.   r> base ! ;
  134. : wd  ' dp ;
  135.  
  136. .( file utilities: dir, ren, del, list, print, copy, ucopy, lcopy ) cr
  137.  
  138. 0 constant rd
  139. 1 constant wr
  140. file file1
  141. file file2
  142.  
  143. : ?emit  dup 0= if drop cr else emit then ;
  144.  
  145. : ren  { 20 locbuff oldname }
  146.   namearg oldname 20 cmove ( ^old name)
  147.   oldname namearg  ( ^new name) rename
  148.   0= not if ." old file not found" then ;
  149.   
  150. : list  file1 rd namearg fopen   cr
  151.    begin file1 getc   dup 0< ?key or not
  152.    while ?emit repeat   drop
  153.    file1 fclose ;
  154. : copy    file1 rd namearg fopen   file2 wr namearg fopen
  155.    begin file1 getc
  156.    dup 0< not
  157.    while file2 putc repeat   drop
  158.    file1 fclose   file2 fclose ;
  159. : print    file1 rd namearg fopen
  160.    file2 wr " prn:"  over >r  + 0 swap c! r>  fopen
  161.    begin file1 getc
  162.    dup 0< not
  163.    while file2 putc repeat   drop
  164.    file1 fclose   file2 fclose ;
  165. : ucopy  file1 rd namearg fopen   file2 wr namearg fopen
  166.    begin file1 getc
  167.    dup 0< not
  168.    while dup  islower if upper then  file2 putc repeat
  169.    drop   file1 fclose   file2 fclose ;
  170. : lcopy  file1 rd namearg fopen   file2 wr namearg fopen
  171.    begin file1 getc
  172.    dup 0< not
  173.    while dup  isupper if lower then  file2 putc repeat
  174.    drop   file1 fclose   file2 fclose ;
  175.  
  176. : blkname  getdta 30 +  12 bl fill ;
  177.  
  178. : getfirst  { 2 regargs &buffer &ambig }
  179.  
  180.   bl word dup c@
  181.   
  182.   if  0 &ambig ! count  else drop " *.*"  then
  183.   1+ &buffer swap cmove ( initialise buffer)
  184.   
  185.   &buffer 31 ( file attributes) sfirst ;
  186.  
  187. : .name  { 1 regarg ptr  2 regs char #chars }
  188.  
  189.    8 to #chars
  190.    begin
  191.      ptr inc c@ to char
  192.      char 0>  char [ascii] . = not and  #chars and
  193.    while
  194.      char emit -1 addto #chars
  195.    repeat
  196.    1 addto #chars  for #chars space next 
  197.    
  198.    3 to #chars
  199.    for #chars
  200.      ptr inc c@  to char
  201.      char bl > if char else bl then emit
  202.    next ;
  203.  
  204. : funct { 1 reg what }
  205.    5 - c@ to what
  206.    what case
  207.     1  of  " <WPROT>" endof
  208.     2  of  " <HID>" endof
  209.     4  of  " <SYS>" endof
  210.     8  of  " <VOL>" endof
  211.    16  of  " <DIR>" endof
  212.            " <EMPTY>" ( default)
  213.    endcase ;
  214.  
  215. : .size  dup @
  216.    if @ 8 u.r  else  funct 8 type.r then  2 spaces ;
  217. : .day  31 and # # ;
  218. : .month  5 lsr 15 and # # [ascii] - hold ;
  219. : .year  9 lsr 127 and  80 + # # [ascii] - hold ;
  220. : .date  w@  <#  dup >r .year drop
  221.       r@  .month drop   r> .day  #>  type ;
  222. : .fname  5 spaces
  223.    getdta dup  30 + .name
  224.    dup 26 +  .size 
  225.    24 + .date ;
  226.  
  227. : dir  { 3 locals ambig numbase column  20 locbuff name }
  228.    0 to column base @ to numbase  decimal  cr
  229.    blkname
  230.    name addr ambig getfirst 0< not
  231.    if
  232.     begin
  233.      .fname
  234.      column  if cr 0  else 5 spaces 1  then  to column
  235.      blkname snext
  236.     0< until
  237.    then
  238.    numbase base ! ;
  239.  
  240. : delfile  getdta 30 + delete ;
  241.  
  242. : del  { 1 local ambig 20 locbuff name }
  243.    blkname  1 to ambig
  244.    name addr ambig getfirst
  245.    ambig if ." delete all files (y/n)?"
  246.             key dup [ascii] y = swap  [ascii] Y = or not
  247.             if abort then
  248.          then
  249.    0< not ( first found)
  250.    if
  251.     begin  delfile  blkname snext  0< until
  252.    then
  253. ;
  254.  
  255. \ clean up the lower-level words:
  256.  
  257.  from utilities
  258.  
  259. keep dp    keep wd
  260. keep dump  keep mdump    keep blksave
  261. keep list  keep print
  262. keep copy  keep ucopy    keep lcopy
  263. keep dir   keep ren      keep del
  264.  
  265. public
  266.  
  267. load a:\lib\what.s
  268.