home *** CD-ROM | disk | FTP | other *** search
/ Dream 48 / Amiga_Dream_48.iso / Atari / forth / forst.zoo / forst / lib / apputils.s < prev    next >
Text File  |  1990-12-10  |  3KB  |  140 lines
  1. ( apputils.s:  redefinitions for stand-alone code
  2.   assumes that vector words have been loaded from preface.s)
  3.  
  4. decimal
  5.  
  6. another u/mod
  7.  
  8. ( string package )
  9.  
  10. : count  ( addr--addr+1,cnt) to a0  a0 inc c@ to d0  a0 d0 ;
  11.  
  12. : even  to a1  a1 1 and addto a1  a1 ;
  13. : (")  r> count  over over + 1+ even  >r ;   head (") is >(")
  14.  
  15. : abs  to a1  a1 0< if 0 a1 -  else a1 then ;
  16.  
  17. : emit
  18.   a7 dec w! ( char) 2 a7 dec w! gemdos
  19.   4 addto a7 ;
  20.   
  21. : cr 13 emit 10 emit ;
  22.   
  23. : key
  24.   7 a7 dec w! gemdos
  25.   d0 a6 dec w!  0 a6 dec w! ( extend char to long word)
  26.   2 addto a7 ;
  27.  
  28. : wait  key drop ;
  29.  
  30. : key? 
  31.   11 a7 dec w!  gemdos  d0 a6 dec w! 0 a6 dec w!
  32.   2 addto a7 ;
  33.   
  34. : ?key  key?  if wait wait then ;
  35.  
  36. : type  ( ptr,len)
  37.   { 2 args ptr len }
  38.   for len  ptr inc c@ emit next ;  head type is >type
  39.  
  40. : fill { 3 regargs ptr len val }
  41.   for len  val ptr inc c!  next ;
  42.  
  43. : cmove  ( orig,dest,len)
  44.   { 3 regargs orig dest len }
  45.   for len orig inc c@ dest inc c! next ;
  46.  
  47. : cmove>  ( orig,dest,len)
  48.   { 3 regargs orig dest len }
  49.   len addto orig  len addto dest
  50.   for len orig dec c@ dest dec c! next ;
  51.   
  52. : move
  53.   { 3 args orig dest len }
  54.   orig dest len
  55.   dest orig >  if  cmove>  else  cmove  then ;
  56.   
  57. ( expect package)
  58. : expects ;
  59.  
  60. 32 constant blank
  61. 13 constant cret
  62. 8 constant bs
  63. 27 constant esc
  64.  
  65. : backup  bs emit blank emit bs emit ; 
  66. : bspaces  { 1 regarg cnt }
  67.   for cnt  backup  next ;
  68.  
  69. : docontrol { 4 args char &ptr &got &more  1 local sofar }
  70.  
  71.   &got @ to sofar
  72.  
  73.   char bs =
  74.   if sofar 0>
  75.     if  -1 &got +!
  76.          1 &more +!
  77.         -1 &ptr +!  blank &ptr @ c!
  78.         backup
  79.     then  exit
  80.   then
  81.  
  82.   char esc =
  83.   if  sofar 0>
  84.     if  0 &got !
  85.         sofar &more +!
  86.         sofar negate &ptr +!
  87.         &ptr @ sofar blank fill 
  88.         sofar bspaces
  89.     then
  90.   then
  91. ;
  92.  
  93. : (expect) { 2 args ptr #chars 3 locals char #got #more }
  94.  
  95.         ptr #chars blank fill
  96.         0 to #got  #chars to #more
  97.         
  98.         begin #more if  key to char  then
  99.               #more  char cret = not  and
  100.         while char blank <
  101.               if  char  addr ptr  addr #got  addr #more  docontrol
  102.               else char ptr inc c!
  103.                 1 addto #got
  104.                 -1 addto #more
  105.                 char emit
  106.               then
  107.         repeat
  108. ;      
  109.  
  110. from expects keep expect public
  111.  
  112. ( integer output package )
  113. : dots ;
  114.  
  115. variable base  10 base !  ( decimal default )
  116. 32 constant blank
  117. 45 constant minus
  118. 48 constant zero
  119. 20 constant maxlen
  120. 65 10 - constant hexdigit
  121.  
  122. another u/mod
  123.  
  124. : (.) ( numb)
  125.   { 1 arg numb  4 locals sign ptr len numbase  maxlen locbuff string }
  126.  
  127.   numb to sign  numb abs to numb  base @ to numbase
  128.   0 to len  string maxlen +  to ptr   ( output pointer)  
  129.  
  130.   begin
  131.      numb numbase u/mod  to numb
  132.      dup 10 < if zero  else hexdigit then  +
  133.      ptr dec c!  1 addto len  ( store char )
  134.   numb 0= until     
  135.   sign 0<  if  minus ptr dec c!  1 addto len  then
  136.  
  137.   ptr len type  blank emit ;
  138.  
  139. from dots keep base keep (.) public
  140.