Subversion Repositories Kolibri OS

Rev

Blame | Last modification | View Log | Download | RSS feed

  1.  
  2. ~mak\utils.f
  3.  
  4. CREATE  GetOp_STR  80 ALLOT
  5. C" SkipDelimiters" FIND NIP 0=
  6. [IF]
  7. : 2+ 2 + ;
  8. : 0! OFF ;
  9. : 1+! incr ;
  10. : 1-! DECR ;
  11. : EndOfChunk ( -- flag )
  12.   >IN @ SOURCE NIP < 0=        \ >IN ­¥ ¬¥­ìè¥, 祬 ¤«¨­  ç ­ª 
  13. ;
  14.  
  15. : CharAddr ( -- c-addr )
  16.   SOURCE DROP >IN @ +
  17. ;
  18.  
  19. : PeekChar ( -- char )
  20.   CharAddr C@       \ ᨬ¢®« ¨§ ⥪ã饣® §­ ç¥­¨ï >IN
  21. ;
  22.  
  23. : GetChar ( -- char flag )
  24.   EndOfChunk
  25.   IF 0 FALSE
  26.   ELSE PeekChar TRUE THEN
  27. ;
  28.  
  29. : IsDelimiter ( char -- flag )
  30.   BL 1+ < ;
  31.  
  32. : OnDelimiter ( -- flag )
  33.   GetChar SWAP IsDelimiter AND
  34. ;
  35.  
  36. : SkipDelimiters ( -- ) \ ¯à®¯ãáâ¨âì ¯à®¡¥«ì­ë¥ ᨬ¢®«ë
  37.   BEGIN
  38.     OnDelimiter
  39.   WHILE
  40.     >IN 1+!
  41.   REPEAT
  42. ;
  43.  
  44. : RDROP POSTPONE R>DROP ; IMMEDIATE
  45.  
  46. [THEN]
  47.  
  48. : OnNotDelimiter_ ( C -- flag )
  49.   DUP [CHAR] 0 U<  IF DROP FALSE EXIT THEN
  50.   DUP [CHAR] : U<  IF DROP TRUE  EXIT THEN
  51.   DUP [CHAR] @ U<  IF DROP FALSE EXIT THEN
  52.   DUP [CHAR] [ U<  IF DROP TRUE  EXIT THEN
  53.   DUP [CHAR] _  =  IF DROP TRUE  EXIT THEN
  54.   DUP [CHAR] a U<  IF DROP FALSE EXIT THEN
  55.   DUP [CHAR] { U<  IF DROP TRUE  EXIT THEN
  56.                       DROP FALSE
  57. ;
  58.  
  59. : SkipWord_ ( -- ) \ ¯à®¯ãáâ¨âì term ᨬ¢®«ë
  60.   BEGIN
  61.   GetChar  IF  OnNotDelimiter_  THEN
  62.   WHILE
  63.     >IN 1+!
  64.   REPEAT ;
  65.  
  66. : ParseWord_ ( -- c-addr u )
  67.   CharAddr >IN @
  68.   SkipWord_
  69.   >IN @ - NEGATE ;
  70.  
  71. C" UPPER" FIND NIP 0=
  72. [IF]
  73.  
  74. BASE @ HEX
  75. : UPC  ( c -- c' )
  76.   DUP [CHAR] Z U>
  77.   IF  DF AND
  78.   THEN   ;
  79.  
  80. BASE !
  81.  
  82. : UPPER ( ADDR LEN -- )
  83.  0 ?DO COUNT UPC OVER 1- C! LOOP DROP ;
  84.  
  85. [THEN]
  86.  
  87. : IN>R  POSTPONE >IN
  88.        POSTPONE @
  89.        POSTPONE >R ; IMMEDIATE
  90.  
  91. : R>IN  POSTPONE R>
  92.        POSTPONE >IN
  93.        POSTPONE !   ; IMMEDIATE
  94.  
  95. : GetOp_BS ParseWord_ GetOp_STR PLACE  GetOp_STR ;
  96.  
  97. : non-term 1 GetOp_STR C! PeekChar GetOp_STR 1+ C! >IN 1+! GetOp_STR  ;
  98.  
  99. : TERM-STR  CharAddr SkipWord_ CharAddr  OVER -
  100.            GetOp_STR PLACE  GetOp_STR DUP COUNT UPPER  ;
  101.  
  102. \ types:        1 - non-term (comments, etc.)
  103. \              2 - number
  104. \              3 - name
  105. \              4 - "-bracketed string
  106. \              5 - '-bracketed string
  107.  
  108. CREATE XXX 0 ,
  109. : (GetOp) ( --> string type )
  110.         SkipDelimiters
  111.         GetChar 0= IF DROP XXX FALSE EXIT THEN
  112.         DUP [CHAR] 0 <
  113.         IF DUP [CHAR] "  =
  114.           IF  [CHAR] " GetOp_BS 4 EXIT
  115.            THEN
  116.                [CHAR] '  =
  117.           IF  [CHAR] ' GetOp_BS 5 EXIT
  118.            THEN non-term         1 EXIT
  119.         THEN
  120.         DUP [CHAR] : <
  121.         IF DROP TERM-STR 2 EXIT
  122.         THEN
  123.           OnNotDelimiter_
  124.         IF     TERM-STR 3 EXIT
  125.         THEN   non-term 1  ;
  126.  
  127. : IFNOT POSTPONE 0=
  128.         POSTPONE IF ; IMMEDIATE
  129.  
  130. 1000 ALLOT
  131. HERE CONSTANT LS0
  132. VARIABLE LSP
  133. LS0  LSP !
  134.  
  135. :  ADDNUMOBJECT ( name addr type --> )
  136.  -11 LSP +!
  137.      LSP @ C!
  138.   11 LSP @ 1+ W!
  139.      LSP @ 3 + !
  140.      LSP @ 7 + ! ;
  141.  
  142.  
  143. : AddStrObject ( name addr type --> )
  144.   ROT
  145.   DUP C@ 1+ NEGATE LSP +!
  146.   COUNT LSP @ PLACE   \ addr type
  147.   -7 LSP +!
  148.      LSP @ C!
  149.      LSP @ 7 + C@ 8 +
  150.      LSP @ 1+ W!
  151.      LSP @ 3 + ! ;
  152.  
  153. 0
  154. 1 FIELD  L_TYPE
  155. 2 FIELD  L_SIZE
  156. 4 FIELD  L_ADDR
  157. 0 FIELD  L_NAME
  158. DROP
  159.  
  160. : FindStrObject ( name type --> addr true | false )
  161.   LSP @ >R
  162.   BEGIN R@ L_SIZE W@
  163.   WHILE
  164.     DUP R@ L_TYPE C@ =
  165.     IF        OVER R@ L_SIZE W@ 7 -
  166.         R@ L_NAME  R@ L_SIZE W@ 7 - COMPARE 0=
  167.         IF 2DROP   R> L_ADDR @ TRUE EXIT
  168.         THEN
  169.     THEN   R@ L_SIZE W@ R> + >R
  170.   REPEAT   2DROP RDROP FALSE  ;
  171.  
  172. CREATE NullString 0 ,
  173.  
  174.  
  175. : ConvertString ;
  176.  
  177. : S= ( c-addr1 c-addr2 --> true | c-addr1 false )
  178.   OVER COUNT ROT COUNT
  179.   COMPARE
  180.   IF    FALSE
  181.   ELSE  DROP TRUE
  182.   THEN ;
  183. : ?S= ( flag n R: >IN --> R: >IN | -->> n true )
  184.   SWAP
  185.   IF  2R> 2DROP TRUE EXIT
  186.   THEN DROP
  187. ;
  188.  
  189.  
  190. ALSO FORTH DEFINITIONS
  191.  
  192. : VAL ( ADDR -- UD2 FLAG )
  193.  0 0 ROT COUNT >NUMBER NIP 0= ;
  194.  
  195. VARIABLE CUR-PAB
  196. HERE 0 , CUR-PAB !
  197.  
  198. : ?PABLIC ( CFA -- FLAG )
  199.    CUR-PAB @
  200.    BEGIN 2DUP @ U<
  201.    WHILE @
  202.    REPEAT CELL+ @ = ;
  203.  
  204. : PABLIC ( -- )
  205.   HERE CUR-PAB @ , LAST @ NAME> ,  CUR-PAB ! ;
  206.  
  207. : >L
  208.  -4 LSP  +!
  209.     LSP @ ! ;
  210.  
  211. : L>
  212.    LSP @ @
  213.  4 LSP  +! ;
  214.  
  215. : ERR_  TRUE ABORT"  " ;
  216.  
  217. C" 1-!" FIND NIP 0=
  218. [IF]
  219. : 1-! ( ADDR -- )
  220.   DUP>R @ 1- R> ! ;
  221. [THEN]
  222.  
  223. C" ON" FIND NIP 0=
  224. [IF]
  225. : ON ( ADDR -- )
  226.   TRUE SWAP ! ;
  227. [THEN]
  228.  
  229. C" ?PAIRS" FIND NIP 0=
  230. [IF]
  231. : ?PAIRS  XOR ABORT" conditionals not paired" ;
  232. [THEN]
  233.  
  234. \ : 'Alias ' Alias ;
  235. PREVIOUS DEFINITIONS
  236.  
  237.  
  238.