home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / f88 / utils.bak < prev    next >
Encoding:
Text File  |  1988-06-06  |  6.4 KB  |  209 lines
  1. \ UTILS.SEQ     Some basic utilities
  2.  
  3.  
  4. : ?             ( adr -- )
  5.                 @ .   ;
  6.  
  7. : YCOUNT        ( a1 --- a2 n1 )
  8.                 DUP 1+ SWAP YC@ ;
  9.  
  10. : ?ENOUGH       ( n -- )
  11.                 DEPTH 1- > ABORT" Not enough Parameters" ;
  12.  
  13. : BS'S          ( n1 --- )
  14.                 0 MAX 80 MIN 0 ?DO 8 EMIT -2 #OUT +! LOOP ;
  15.  
  16. : .FREE         ( -- )
  17.                 ." Free Bytes:"
  18.                  ."  CODE = "       SP@       HERE - (U.) TYPE
  19.                 ." , LIST = " #LISTSEGS XHERE DROP XSEG @ - - 16 *D 1 D.R
  20.                 ." , HEAD = " #HEADSEGS 16 * YHERE - (U.) TYPE ;
  21.  
  22. : @REL>ABS      ( A1 --- A2 )         \ CONVERT CONTENTS OF A1
  23.                 DUP 1+ @ SWAP 3 + + ;     \ FROM RELATIVE TO ABSOLUTE
  24.  
  25. : DRIVE?        ( -- )   0 25 BDOS ASCII A + EMIT ." : "  ;
  26.  
  27.                 \ These are needed by later utilities
  28.  
  29. DEFER CCR       ' CR IS CCR             \ Carraige Carraige return?
  30.  
  31. DEFER .DEFSRC   ' NOOP IS .DEFSRC       \ Nothing for now, may be set
  32.                                         \ to display the source for the
  33.                                         \ current definition.
  34.  
  35. VARIABLE DEFCFA                         \ Holds the CFA of the current word.
  36. VARIABLE PFASAV                         \ Current offset into definition.
  37.  
  38. 2VARIABLE CTIME         GETTIME CTIME 2!
  39. 2VARIABLE CDATE         GETDATE CDATE 2!
  40.  
  41. : LARGEST       ( addr n -- addr' val )
  42.                 OVER 0 SWAP ROT 0
  43.                 DO      2DUP @ U<
  44.                         IF      -ROT 2DROP    DUP @ OVER
  45.                         THEN    2+
  46.                 LOOP    DROP   ;
  47.  
  48. \ : LABEL   PRECODE CREATE ASSEMBLER   ;
  49.  
  50. : DOES?         ( IP -- IP' F )  \ IP IS ACTUALLY CFA, IP' IS PFA
  51.                 DUP >BODY SWAP @REL>ABS @REL>ABS
  52.                 ['] FORTH      @REL>ABS @REL>ABS = ;
  53.  
  54. ' HEX @REL>ABS CONSTANT 'DOCOL
  55.  
  56. : >.ID          ( A1 --- )
  57.                 DUP 200 U< IF DROP EXIT THEN
  58.                 128 0
  59.                 DO      DUP @REL>ABS 'DOCOL =
  60.                         IF  LEAVE ELSE 1- THEN
  61.                 LOOP    >NAME .ID ;
  62.  
  63. VARIABLE FUDGE   65  FUDGE !            \  65 =  8Mhz AT Clone
  64.                                         \ 100 = 10Mhz AT Clone
  65. : MS   ( n -- )
  66.    0 ?DO   FUDGE @ 0 ?DO PAUSE LOOP  LOOP  ;
  67.  
  68. HEX
  69. : setfudge      ( --- ) ( DEFERS INITSTUFF ) SEQINIT
  70.                 F000 FFFE c@l 00FC =         \ 00FC = PCAT
  71.                 if 41 else 0F then fudge ! ; \ 00FF = PC
  72.                                              \ 00FE = XT
  73. ' SETFUDGE IS INITSTUFF                      \ 00FD = PCjr
  74.                                              \ 002D = Compaq PC
  75.                                              \ 009A = Compaq XT
  76. DECIMAL
  77.  
  78. : U<=   ( u1 u2 -- f )   U> NOT   ;
  79. : U>=   ( u1 u2 -- f )   U< NOT   ;
  80. : <=    ( n1 n2 -- f )   > NOT    ;
  81. : >=    ( n1 n2 -- f )   < NOT    ;
  82. : 0>=   ( n1 n2 -- f )   0< NOT   ;
  83. : 0<=   ( n1 n2 -- f )   0> NOT   ;
  84.  
  85. VARIABLE #TIMES   ( # times already performed )   1 #TIMES !
  86.  
  87. : TIMES   ( n -- )
  88.    1 #TIMES +!  #TIMES @
  89.    < IF  1 #TIMES !  ELSE  >IN OFF  THEN   ;
  90.  
  91. : MANY   ( -- )
  92.    KEY? NOT IF   >IN OFF   THEN   ;
  93.  
  94.  
  95.  
  96. : AT            ( col row -- )  ( 0 0 is upper left )
  97.                 DOES>  >R 2DUP R> PERFORM  #LINE !  #OUT ! ; AT
  98.  
  99. : DARK          ( -- )
  100.                 DOES>  PERFORM   #LINE OFF  #OUT OFF   ; DARK
  101.  
  102. : ?DARK         ( -- )
  103.                 KEY? 0= IF DARK CR THEN ;
  104.  
  105. DEFER -LINE
  106.  
  107. VARIABLE #PAGE
  108.  
  109. : PAGE   ( -- )
  110.    DOES> PERFORM   1 #PAGE +!   #LINE OFF   #OUT OFF   ; PAGE
  111.  
  112. : FORM-FEED   ( -- )   CONTROL M EMIT   CONTROL L EMIT  ;
  113.  
  114. ' FORM-FEED IS PAGE
  115.  
  116. : ?PAGE         ( --- )         \ PAGE IF LINE CNT NOT ZERO
  117.                 #LINE @
  118.                 IF      PAGE
  119.                 THEN    ;
  120.  
  121. : TILLKEY       ( N1 --- )      \ WAIT UP TO N1 SECONDS FOR A KEY THEN GO ON.
  122.                 KEY?    IF  DROP EXIT  THEN     \ LEAVE IF KEY PRESSED
  123.                 CR ."  Waiting, press SPACEBAR to continue.."
  124.                 0 MAX 0
  125.                 ?DO     KEY?    ?LEAVE
  126.                         1 SECONDS
  127.                 LOOP    KEY?
  128.                 IF      KEY 3 = ABORT" Quitting " THEN ;
  129.  
  130. : ALIAS         ( A1 | alias_NAME --- ) \ creates alias_NAME pointing
  131.                 >R CREATE -3 ALLOT YHERE 2-        \ A1=CFA OF REAL NAME
  132.                 R> >NAME YCOUNT 31 AND + Y@
  133.                 SWAP Y! ;
  134.  
  135.  
  136. VARIABLE NLEN
  137.  
  138. : >NAME.ID      ( CFA --- )
  139.                 >NAME DUP YC@ 31 AND DUP ?LINE NLEN ! .ID ;
  140.  
  141. DEFER (SEE)
  142.  
  143. DEFER INSTALLSTUFF      ' NOOP IS INSTALLSTUFF
  144. DEFER UNINSTALLSTUFF    ' NOOP IS UNINSTALLSTUFF
  145.  
  146. DEFER >ATTRIB1          ' NOOP IS >ATTRIB1
  147. DEFER >ATTRIB2          ' NOOP IS >ATTRIB2
  148. DEFER >ATTRIB3          ' NOOP IS >ATTRIB3
  149. DEFER >ATTRIB4          ' NOOP IS >ATTRIB4
  150. DEFER >ATTRIB5          ' NOOP IS >ATTRIB5
  151. DEFER >ATTRIB6          ' NOOP IS >ATTRIB6
  152. DEFER >ATTRIB7          ' NOOP IS >ATTRIB7
  153. DEFER >ATTRIB8          ' NOOP IS >ATTRIB8
  154.  
  155.  
  156.  
  157. DEFER >NORM             ' NOOP IS >NORM
  158.  
  159. DECIMAL
  160.  
  161. VARIABLE RESTBASE       10 RESTBASE !
  162. VARIABLE RESTCAPS       RESTCAPS ON
  163. VARIABLE RESTTABS       8 RESTTABS !
  164. VARIABLE RESTLMRG       RESTLMRG OFF
  165. VARIABLE RESTRMRG       70 RESTRMRG !
  166. VARIABLE RESTSTAT       RESTSTAT OFF
  167. VARIABLE STATV          STATV OFF
  168.  
  169. : SAVESTATE     ( --- )
  170.                 BASE @ RESTBASE !
  171.                 CAPS @ RESTCAPS !
  172.                 LMARGIN @ RESTLMRG !
  173.                 RMARGIN @ RESTRMRG !
  174.                 TABSIZE @ RESTTABS !
  175.                 STATV   @ RESTSTAT ! ;
  176.  
  177. : RESTORESTATE  ( --- )
  178.                 RESTSTAT @ STATV !
  179.                 RESTBASE @ BASE !
  180.                 RESTCAPS @ CAPS !
  181.                 RESTLMRG @ LMARGIN !
  182.                 RESTRMRG @ RMARGIN !
  183.                 RESTTABS @ TABSIZE ! ;
  184.  
  185. : DEFAULTSTATE  ( --- )
  186.                 RESTSTAT ON
  187.                 10 RESTBASE !
  188.                 RESTCAPS ON
  189.                 8 RESTTABS !
  190.                 RESTLMRG OFF
  191.                 70 RESTRMRG !
  192.                 RESTORESTATE ;
  193.  
  194. : ?DOSTOP       ( F1 --- )
  195.                 IF      RESTORESTATE
  196.                         TRUE ABORT" Stopped"
  197.                 THEN    ;
  198.  
  199. : ?KEYPAUSE     ( --- )         \ Pause if key pressed
  200.                 KEY?
  201.                 IF      KEY 27 = ?DOSTOP
  202.                         KEY 27 = ?DOSTOP
  203.                 THEN    ;
  204.  
  205. : $>TIB         ( a1 --- )
  206.                 COUNT >R TIB R@ CMOVE R@ SPAN ! R> #TIB ! >IN OFF  ;
  207.  
  208.  
  209.