home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / utils.seq < prev    next >
Encoding:
Text File  |  1991-04-23  |  10.1 KB  |  310 lines
  1. \ UTILS.SEQ     Some basic utilities
  2.  
  3. 35505. 2CONSTANT FPCVER#        \ version number of F-PC, always 5 digits
  4.  
  5. : .FPCVER#      ( -- )          \ display version number in a 6 char field
  6.                                 \ with 1 leading, and 1 trailing space
  7.                 FPCVER# 100 UM/MOD NIP        \ discard last two digits
  8.                 0 <# BL HOLD # # '.' HOLD # BL HOLD #> TYPE ;
  9.  
  10. : .VERSION      ( -- )
  11.                 FPCVER# <# BL HOLD # # # # '.' HOLD # BL HOLD #> TYPE ;
  12.  
  13. : ?             ( adr -- )
  14.                 @ .   ;
  15.  
  16. : YCOUNT        ( a1 --- a2 n1 )
  17.                 DUP 1+ SWAP YC@ ;
  18.  
  19. : ?ENOUGH       ( n -- )
  20.                 DEPTH 1- > ABORT" Not enough Parameters" ;
  21.  
  22. TRUE  VALUE ?DOSIO
  23.  
  24. : SP>COL        ( n1 -- )
  25.                 #OUT @ - SPACES ;
  26.  
  27. : EEOL          ( col -- )
  28.                 COLS ?DOSIO + SP>COL ;
  29.  
  30. : .FREE         ( -- )
  31.                 ." Free Bytes:"
  32.                  ."  CODE = "       SP@       HERE - (U.) TYPE
  33.                 ." , LIST = " #LISTSEGS XHERE DROP XSEG @ - - 16 *D 1 D.R
  34.                 ." , HEAD = " #HEADSEGS 16 * YHERE - (U.) TYPE ;
  35.  
  36. : .MEM          ( -- )
  37.                 SAVE> BASE DECIMAL
  38.                 CR ." -------- DOS memory usage"
  39.                 PHEAD @
  40.                 BEGIN   ?DUP
  41.                 WHILE   CR DUP 2+ @ 16 *D 8 D.R ."  bytes "
  42.                         DUP 2- @ ?DUP
  43.                         IF      ." at segment " H.
  44.                         ELSE    ." Unallocated"
  45.                         THEN    YDP @
  46.                         IF      32 SP>COL DUP 2- BODY> >NAME .ID
  47.                         THEN    @
  48.                 REPEAT  CR
  49.                 MAXBLOCK 16 *D 2DUP 8 D.R ."  bytes DOS memory Available" CR
  50.                 #PARS @ 0 2 UM/MOD TUCK + 16 *D ROT 16 *D D+ D+ 8 D.R
  51.                                 \ the above garbage is done to assure
  52.                                 \ we get an unsigned result, as #PARS
  53.                                 \ could be negative to start with.
  54.                 ."  bytes DOS memory Total" CR CR
  55.                 EMM-PRESENT?
  56.                 IF      ." -------- Expanded Memory Version "
  57.                         HEX     EMM-GET-VERSION 0 <# # '.' HOLD # #> TYPE
  58.                         DECIMAL
  59.                         CR EMM-AVAIL-PAGES 16384 *D 8 D.R
  60.                         ."  bytes expanded memory  Available"
  61.                         CR EMM-TOTAL-PAGES 16384 *D 8 D.R
  62.                         ."  bytes expanded memory  Total"
  63.                 ELSE    ." ----- NO Expanded Memory present"
  64.                 THEN    RESTORE> BASE ;
  65.  
  66. : DRIVE?        ( -- )   0 25 BDOS 'A' + EMIT ." : "  ;
  67.  
  68.                 \ These are needed by later utilities
  69.  
  70. DEFER CCR       ' CR IS CCR             \ Carraige Carraige return?
  71. DEFER .SRCCR    ' CR IS .SRCCR
  72.  
  73. VARIABLE DEFCFA                         \ Holds the CFA of the current word.
  74. VARIABLE PFASAV         -1 PFASAV !     \ Current offset into definition.
  75.  
  76. 2VARIABLE CTIME         GETTIME CTIME 2!
  77. 2VARIABLE CDATE         GETDATE CDATE 2!
  78.  
  79. : $.R   ( addr len n1 -- )   TUCK UMIN TUCK - -ROT TYPE SPACES ;
  80. : $.L   ( addr len n1 -- )   TUCK UMIN TUCK - SPACES TYPE ;
  81.  
  82. : DOES?         ( IP -- IP' F )  \ IP IS ACTUALLY CFA, IP' IS PFA
  83.                 DUP >BODY SWAP @REL>ABS @REL>ABS
  84.                 ['] FORTH      @REL>ABS @REL>ABS = ;
  85.  
  86. ' HEX @REL>ABS CONSTANT 'DOCOL
  87.  
  88. : >.ID          ( A1 --- )
  89.                 DUP 200 U< IF DROP EXIT THEN
  90.                 128 0
  91.                 DO      DUP @REL>ABS 'DOCOL =
  92.                         IF  LEAVE ELSE 1- THEN
  93.                 LOOP    >NAME .ID ;
  94.  
  95. : U<=   ( u1 u2 -- f )   U> NOT   ;
  96. : U>=   ( u1 u2 -- f )   U< NOT   ;
  97. : <=    ( n1 n2 -- f )   > NOT    ;
  98. : >=    ( n1 n2 -- f )   < NOT    ;
  99. : 0>=   ( n1 n2 -- f )   0< NOT   ;
  100. : 0<=   ( n1 n2 -- f )   0> NOT   ;
  101.  
  102. VARIABLE #TIMES   ( # times already performed )   1 #TIMES !
  103.  
  104. : TIMES   ( n -- )
  105.    1 #TIMES +!  #TIMES @
  106.    < IF  1 #TIMES !  ELSE  >IN OFF  THEN   ;
  107.  
  108. : MANY   ( -- )
  109.    KEY? NOT IF   >IN OFF   THEN   ;
  110.  
  111. : AT            ( col row -- )  ( 0 0 is upper left )
  112.                 DOES>  >R 2DUP R> PERFORM  #LINE !  #OUT ! ; AT
  113.  
  114. ' 2DROP IS AT
  115.  
  116.  
  117. : DARK          ( -- )
  118.                 DOES>  PERFORM   #LINE OFF  #OUT OFF   ; DARK
  119.  
  120. ' NOOP IS DARK
  121.  
  122. : ?DARK         ( -- )
  123.                 KEY? 0= IF DARK CR THEN ;
  124.  
  125. DEFER AT?
  126. DEFER -LINE
  127.  
  128. : SAVECURSOR    ( -- )          \ save all of the current cursor stuff
  129.                 2R>
  130.                 @> ATTRIB >R            \ save attribute
  131.                 GET-CURSOR >R           \ cursor shape
  132.                 @> #OUT @> #LINE 2>R    \ and position
  133.                 2>R ;
  134.  
  135. : RESTCURSOR    ( -- )          \ restore all of the cursor stuff
  136.                 2R>
  137.                 2R> AT                  \ restore position
  138.                 R> SET-CURSOR           \ shape
  139.                 R> ATTRIB !             \ and attribute
  140.                 2>R ;
  141.  
  142. 0 VALUE ?DOINGMAC       \ Are we doing a macro, moved her from macros
  143.                         \ to make it available for testing by programs
  144.                         \ that may want to know if we are in the middle
  145.                         \ of a macro.
  146.  
  147. VARIABLE #PAGE
  148.  
  149. : PAGE   ( -- )
  150.    DOES> PERFORM   1 #PAGE +!   #LINE OFF   #OUT OFF   ; PAGE
  151.  
  152. : FORM-FEED   ( -- )   CONTROL M EMIT   CONTROL L EMIT  ;
  153.  
  154. ' FORM-FEED IS PAGE
  155.  
  156. : ?PAGE         ( --- )         \ PAGE IF LINE CNT NOT ZERO
  157.                 #LINE @
  158.                 IF      PAGE
  159.                 THEN    ;
  160.  
  161. : ALIAS         ( A1 | alias_NAME --- )
  162.                 HEADER YHERE 2- Y! ;
  163.  
  164. : \UNLESS       ( NAME --- )    \ comment out line unless name is defined
  165.                 DEFINED NIP 0=
  166.                 IF      [COMPILE] \
  167.                 THEN    ; IMMEDIATE
  168.  
  169. ' \UNLESS ALIAS \U IMMEDIATE
  170. ' \UNLESS ALIAS \+ IMMEDIATE
  171.  
  172. : \|UNLESS      ( name -- )     \ comment out line if name is defined
  173.                 DEFINED NIP
  174.                 IF      [COMPILE] \
  175.                 THEN    ; IMMEDIATE
  176.  
  177. ' \|UNLESS ALIAS \|U IMMEDIATE
  178. ' \|UNLESS ALIAS \-  IMMEDIATE
  179.  
  180. \ ***************************************************************************
  181. \ defining word, creates words that control compilation of a program.
  182.  
  183. : DIRECTIVE     ( flag | name -- )
  184.                 CREATE , IMMEDIATE
  185.                 DOES> @ 0=
  186.                 IF      [COMPILE] \
  187.                 THEN    ;
  188.  
  189. TRUE  DIRECTIVE \FPC            \ true  = load line following \FPC
  190. FALSE DIRECTIVE \TCOM           \ false = don't load line following \TCOM
  191.  
  192. ' \FPC  ALIAS \F IMMEDIATE      \ create a couple of alias's for convenience
  193. ' \TCOM ALIAS \T IMMEDIATE
  194.  
  195. \ These words can be treated like VALUE's, set them TRUE to make them load
  196. \ the lines following themselves, and make them FALSE to prevent them
  197. \ from loading the line following.
  198.  
  199. \ ***************************************************************************
  200.  
  201. ' !>       ALIAS =: IMMEDIATE   \ make =: the same as !>
  202.  
  203. VARIABLE NLEN
  204. 0 VALUE ?DEFATTRIB
  205.  
  206. : >NAME.ID      ( CFA --- )
  207.                 >NAME DUP YC@ 31 AND DUP ?LINE NLEN !
  208.                 ?DEFATTRIB
  209.                 IF      %.ID
  210.                 ELSE    .ID
  211.                 THEN    ;
  212.  
  213. DEFER (SEE)
  214.  
  215. : <GRAPHDUMMY>  ( --- )
  216.                 CR ." Enter a KEY " KEY TRUE ;
  217.  
  218. DEFER GRAPHCHAR         ' <GRAPHDUMMY> IS GRAPHCHAR
  219.  
  220. DEFER >ATTRIB1          ' NOOP IS >ATTRIB1
  221. DEFER >ATTRIB2          ' NOOP IS >ATTRIB2
  222. DEFER >ATTRIB3          ' NOOP IS >ATTRIB3
  223. DEFER >ATTRIB4          ' NOOP IS >ATTRIB4
  224. DEFER >ATTRIB5          ' NOOP IS >ATTRIB5
  225. DEFER >ATTRIB6          ' NOOP IS >ATTRIB6
  226. DEFER >ATTRIB7          ' NOOP IS >ATTRIB7
  227. DEFER >ATTRIB8          ' NOOP IS >ATTRIB8
  228.  
  229. DEFER >NORM             ' NOOP IS >NORM
  230. DEFER >REV              ' NOOP IS >REV
  231. DEFER >NORMBG           ' NOOP IS >NORMBG
  232.  
  233. DEFER DOBUTTON          ' NOOP IS DOBUTTON
  234. 0 VALUE MOUSEFLG        \ IS THE MOUSE CURRENTLY TURNED ON?
  235.  
  236. DECIMAL
  237.  
  238. VARIABLE RESTBASE       10 RESTBASE !
  239. VARIABLE RESTCAPS       RESTCAPS ON
  240. VARIABLE RESTTABS       8 RESTTABS !
  241. VARIABLE RESTLMRG       RESTLMRG OFF
  242. VARIABLE RESTRMRG       70 RESTRMRG !
  243. VARIABLE RESTSTAT       RESTSTAT OFF
  244. VARIABLE STATV          STATV OFF
  245.  
  246. : SAVESTATE     ( --- )
  247.                 BASE    @ RESTBASE !
  248.                 CAPS    @ RESTCAPS !
  249.                 LMARGIN @ RESTLMRG !
  250.                 RMARGIN @ RESTRMRG !
  251.                 TABSIZE @ RESTTABS !
  252.                 STATV   @ RESTSTAT ! ;
  253.  
  254. : RESTORESTATE  ( --- )
  255.                 RESTSTAT @ STATV !
  256.                 RESTBASE @ BASE !
  257.                 RESTCAPS @ CAPS !
  258.                 RESTLMRG @ LMARGIN !
  259.                 RESTRMRG @ RMARGIN !
  260.                 RESTTABS @ TABSIZE ! ;
  261.  
  262. : DEFAULTSTATE  ( --- )
  263.                 RESTSTAT ON
  264.                 10 RESTBASE !
  265.                 RESTCAPS ON
  266.                 8 RESTTABS !
  267.                 RESTLMRG OFF
  268.                 COLS 10 - RESTRMRG !
  269.                 RESTORESTATE ;
  270.  
  271. : ?DOSTOP       ( F1 --- )
  272.                 IF      RESTORESTATE
  273.                         TRUE ABORT" Stopped"
  274.                 THEN    ;
  275.  
  276. : ?KEYPAUSE     ( --- )         \ Pause if key pressed
  277.                 KEY?
  278.                 IF      KEY 27 = ?DOSTOP
  279.                         KEY 27 = ?DOSTOP
  280.                 THEN    ;
  281.  
  282. : $>TIB         ( a1 --- )
  283.                 COUNT DUP #TIB ! TIB SWAP CMOVE >IN OFF  ;
  284.  
  285. : >PATHEND"     ( A1 --- A2 N1 )        \ RETURN A2 AND COUNT=N1 OF FILENAME
  286.                 COUNT
  287.                 BEGIN   2DUP '\' SCAN ?DUP
  288.                 WHILE   2SWAP 2DROP 1 /STRING
  289.                 REPEAT  DROP ;
  290.  
  291. CREATE DSBUF    6 ALLOT
  292.  
  293. : !USED         ( --- )         \ Save the current dictionary pointers
  294.                 HERE DSBUF !
  295.                 XHERE PARAGRAPH + DSBUF 2+ !
  296.                 YHERE DSBUF 4 + ! ;
  297.      0 DSBUF !
  298. XSEG @ DSBUF 2+ !
  299.      0 DSBUF 4 + !
  300.  
  301. : .USED         ( --- )
  302.                 CR ."   CODE    LIST   HEAD   TOTAL  bytes used"
  303.                 CR HERE DSBUF @ - DUP 6 U.R 0
  304.                 XHERE PARAGRAPH + DSBUF 2+ @ - 16 *D 2DUP 8 UD.R D+
  305.                 YHERE DSBUF 4 + @ - DUP 7 U.R 0 D+ 8 UD.R CR ;
  306.  
  307. : USED          ( <command_line> --- )
  308.                 !USED INTERPRET .USED ;
  309.  
  310.