home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / UTILS.SEQ < prev    next >
Encoding:
Text File  |  1989-09-07  |  7.0 KB  |  234 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. TRUE  VALUE ?DOSIO
  14.  
  15. : EEOL          ( --- )
  16.                 COLS ?DOSIO + #OUT @ - SPACES ;
  17.  
  18. : .FREE         ( -- )
  19.                 ." Free Bytes:"
  20.                  ."  CODE = "       SP@       HERE - (U.) TYPE
  21.                 ." , LIST = " #LISTSEGS XHERE DROP XSEG @ - - 16 *D 1 D.R
  22.                 ." , HEAD = " #HEADSEGS 16 * YHERE - (U.) TYPE ;
  23.  
  24. : DRIVE?        ( -- )   0 25 BDOS 'A' + EMIT ." : "  ;
  25.  
  26.                 \ These are needed by later utilities
  27.  
  28. DEFER CCR       ' CR IS CCR             \ Carraige Carraige return?
  29. DEFER .SRCCR    ' CR IS .SRCCR
  30. DEFER .DEFSRC   ' NOOP IS .DEFSRC       \ Nothing for now, may be set
  31. DEFER .SRCDEF   ' NOOP IS .SRCDEF       \ to display the source for the
  32.                                         \ current definition.
  33.  
  34. VARIABLE DEFCFA                         \ Holds the CFA of the current word.
  35. VARIABLE PFASAV         -1 PFASAV !     \ Current offset into definition.
  36.  
  37. 2VARIABLE CTIME         GETTIME CTIME 2!
  38. 2VARIABLE CDATE         GETDATE CDATE 2!
  39.  
  40. : $.R   ( addr len n1 -- )   TUCK UMIN TUCK - -ROT TYPE SPACES ;
  41. : $.L   ( addr len n1 -- )   TUCK UMIN TUCK - SPACES TYPE ;
  42.  
  43. : DOES?         ( IP -- IP' F )  \ IP IS ACTUALLY CFA, IP' IS PFA
  44.                 DUP >BODY SWAP @REL>ABS @REL>ABS
  45.                 ['] FORTH      @REL>ABS @REL>ABS = ;
  46.  
  47. ' HEX @REL>ABS CONSTANT 'DOCOL
  48.  
  49. : >.ID          ( A1 --- )
  50.                 DUP 200 U< IF DROP EXIT THEN
  51.                 128 0
  52.                 DO      DUP @REL>ABS 'DOCOL =
  53.                         IF  LEAVE ELSE 1- THEN
  54.                 LOOP    >NAME .ID ;
  55.  
  56. : U<=   ( u1 u2 -- f )   U> NOT   ;
  57. : U>=   ( u1 u2 -- f )   U< NOT   ;
  58. : <=    ( n1 n2 -- f )   > NOT    ;
  59. : >=    ( n1 n2 -- f )   < NOT    ;
  60. : 0>=   ( n1 n2 -- f )   0< NOT   ;
  61. : 0<=   ( n1 n2 -- f )   0> NOT   ;
  62.  
  63. VARIABLE #TIMES   ( # times already performed )   1 #TIMES !
  64.  
  65. : TIMES   ( n -- )
  66.    1 #TIMES +!  #TIMES @
  67.    < IF  1 #TIMES !  ELSE  >IN OFF  THEN   ;
  68.  
  69. : MANY   ( -- )
  70.    KEY? NOT IF   >IN OFF   THEN   ;
  71.  
  72. : AT            ( col row -- )  ( 0 0 is upper left )
  73.                 DOES>  >R 2DUP R> PERFORM  #LINE !  #OUT ! ; AT
  74.  
  75. ' 2DROP IS AT
  76.  
  77.  
  78. : DARK          ( -- )
  79.                 DOES>  PERFORM   #LINE OFF  #OUT OFF   ; DARK
  80.  
  81. ' NOOP IS DARK
  82.  
  83. : ?DARK         ( -- )
  84.                 KEY? 0= IF DARK CR THEN ;
  85.  
  86. DEFER AT?
  87. DEFER -LINE
  88.  
  89. : SAVECURSOR    ( -- )          \ save all of the current cursor stuff
  90.                 2R>
  91.                 @> ATTRIB >R            \ save attribute
  92.                 GET-CURSOR >R           \ cursor shape
  93.                 @> #OUT @> #LINE 2>R    \ and position
  94.                 2>R ;
  95.  
  96. : RESTCURSOR    ( -- )          \ restore all of the cursor stuff
  97.                 2R>
  98.                 2R> AT                  \ restore position
  99.                 R> SET-CURSOR           \ shape
  100.                 R> ATTRIB !             \ and attribute
  101.                 2>R ;
  102.  
  103. 0 VALUE ?DOINGMAC       \ Are we doing a macro, moved her from macros
  104.                         \ to make it available for testing by programs
  105.                         \ that may want to know if we are in the middle
  106.                         \ of a macro.
  107.  
  108. VARIABLE #PAGE
  109.  
  110. : PAGE   ( -- )
  111.    DOES> PERFORM   1 #PAGE +!   #LINE OFF   #OUT OFF   ; PAGE
  112.  
  113. : FORM-FEED   ( -- )   CONTROL M EMIT   CONTROL L EMIT  ;
  114.  
  115. ' FORM-FEED IS PAGE
  116.  
  117. : ?PAGE         ( --- )         \ PAGE IF LINE CNT NOT ZERO
  118.                 #LINE @
  119.                 IF      PAGE
  120.                 THEN    ;
  121.  
  122. : ALIAS         ( A1 | alias_NAME --- )
  123.                 HEADER YHERE 2- Y! ;
  124.  
  125. : \UNLESS       ( NAME --- )    \ comment out line unless name is defined
  126.                 DEFINED NIP 0=
  127.                 IF      [COMPILE] \
  128.                 THEN    ; IMMEDIATE
  129.  
  130. ' \UNLESS ALIAS \U IMMEDIATE
  131. ' !>      ALIAS =: IMMEDIATE    \ make =: the same as !>
  132.  
  133. VARIABLE NLEN
  134. 0 VALUE ?DEFATTRIB
  135.  
  136. : >NAME.ID      ( CFA --- )
  137.                 >NAME DUP YC@ 31 AND DUP ?LINE NLEN !
  138.                 ?DEFATTRIB
  139.                 IF      %.ID
  140.                 ELSE    .ID
  141.                 THEN    ;
  142.  
  143. DEFER (SEE)
  144.  
  145. : <GRAPHDUMMY>  ( --- )
  146.                 CR ." Enter a KEY " KEY TRUE ;
  147.  
  148. DEFER GRAPHCHAR         ' <GRAPHDUMMY> IS GRAPHCHAR
  149.  
  150. DEFER >ATTRIB1          ' NOOP IS >ATTRIB1
  151. DEFER >ATTRIB2          ' NOOP IS >ATTRIB2
  152. DEFER >ATTRIB3          ' NOOP IS >ATTRIB3
  153. DEFER >ATTRIB4          ' NOOP IS >ATTRIB4
  154. DEFER >ATTRIB5          ' NOOP IS >ATTRIB5
  155. DEFER >ATTRIB6          ' NOOP IS >ATTRIB6
  156. DEFER >ATTRIB7          ' NOOP IS >ATTRIB7
  157. DEFER >ATTRIB8          ' NOOP IS >ATTRIB8
  158.  
  159. DEFER >NORM             ' NOOP IS >NORM
  160. DEFER >REV              ' NOOP IS >REV
  161. DEFER >NORMBG           ' NOOP IS >NORMBG
  162.  
  163. DEFER DOBUTTON          ' NOOP IS DOBUTTON
  164. 0 VALUE MOUSEFLG        \ IS THE MOUSE CURRENTLY TURNED ON?
  165.  
  166. DECIMAL
  167.  
  168. VARIABLE RESTBASE       10 RESTBASE !
  169. VARIABLE RESTCAPS       RESTCAPS ON
  170. VARIABLE RESTTABS       8 RESTTABS !
  171. VARIABLE RESTLMRG       RESTLMRG OFF
  172. VARIABLE RESTRMRG       70 RESTRMRG !
  173. VARIABLE RESTSTAT       RESTSTAT OFF
  174. VARIABLE STATV          STATV OFF
  175.  
  176. : SAVESTATE     ( --- )
  177.                 BASE    @ RESTBASE !
  178.                 CAPS    @ RESTCAPS !
  179.                 LMARGIN @ RESTLMRG !
  180.                 RMARGIN @ RESTRMRG !
  181.                 TABSIZE @ RESTTABS !
  182.                 STATV   @ RESTSTAT ! ;
  183.  
  184. : RESTORESTATE  ( --- )
  185.                 RESTSTAT @ STATV !
  186.                 RESTBASE @ BASE !
  187.                 RESTCAPS @ CAPS !
  188.                 RESTLMRG @ LMARGIN !
  189.                 RESTRMRG @ RMARGIN !
  190.                 RESTTABS @ TABSIZE ! ;
  191.  
  192. : DEFAULTSTATE  ( --- )
  193.                 RESTSTAT ON
  194.                 10 RESTBASE !
  195.                 RESTCAPS ON
  196.                 8 RESTTABS !
  197.                 RESTLMRG OFF
  198.                 COLS 10 - RESTRMRG !
  199.                 RESTORESTATE ;
  200.  
  201. : ?DOSTOP       ( F1 --- )
  202.                 IF      RESTORESTATE
  203.                         TRUE ABORT" Stopped"
  204.                 THEN    ;
  205.  
  206. : ?KEYPAUSE     ( --- )         \ Pause if key pressed
  207.                 KEY?
  208.                 IF      KEY 27 = ?DOSTOP
  209.                         KEY 27 = ?DOSTOP
  210.                 THEN    ;
  211.  
  212. : $>TIB         ( a1 --- )
  213.                 COUNT DUP #TIB ! TIB SWAP CMOVE >IN OFF  ;
  214.  
  215. CREATE DSBUF    6 ALLOT
  216.  
  217. : !USED         ( --- )         \ Save the current dictionary pointers
  218.                 HERE DSBUF !
  219.                 XHERE PARAGRAPH + DSBUF 2+ !
  220.                 YHERE DSBUF 4 + ! ;
  221.      0 DSBUF !
  222. XSEG @ DSBUF 2+ !
  223.      0 DSBUF 4 + !
  224.  
  225. : .USED         ( --- )
  226.                 CR ."   CODE    LIST   HEAD   TOTAL  bytes used"
  227.                 CR HERE DSBUF @ - DUP 6 U.R 0
  228.                 XHERE PARAGRAPH + DSBUF 2+ @ - 16 *D 2DUP 8 UD.R D+
  229.                 YHERE DSBUF 4 + @ - DUP 7 U.R 0 D+ 8 UD.R CR ;
  230.  
  231. : USED          ( <command_line> --- )
  232.                 !USED INTERPRET .USED ;
  233.  
  234.