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