Subversion Repositories Kolibri OS

Rev

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

  1. ( Ž¯à¥¤¥«ïî騥 á«®¢ , ᮧ¤ î騥 á«®¢ à­ë¥ áâ âì¨ ¢ á«®¢ à¥.
  2.   Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
  3.   Copyright [C] 1992-1999 A.Cherezov ac@forth.org
  4.   à¥®¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
  5.   ¥¢¨§¨ï - ᥭâï¡àì 1999
  6. )
  7.  
  8. USER LAST-CFA
  9. USER-VALUE LAST-NON
  10.  
  11. : REVEAL ( --- )
  12. \ Add the last created definition to the CURRENT wordlist.
  13.   LAST @ CURRENT @ ! ;
  14.  
  15. : SHEADER ( addr u -- )
  16.   _SHEADER  REVEAL
  17. ;
  18.  
  19. : _SHEADER ( addr u -- )
  20.   0 C,     ( flags )
  21.   HERE 0 , ( cfa )
  22.   DUP LAST-CFA !
  23.   -ROT  WARNING @
  24.   IF 2DUP GET-CURRENT SEARCH-WORDLIST
  25.      IF DROP 2DUP TYPE ."  isn't unique" CR THEN
  26.   THEN
  27.   CURRENT @ SWORD,
  28.   ALIGN
  29.   HERE SWAP ! ( § ¯®«­¨«¨ cfa )
  30. ;
  31.  
  32. : HEADER ( "name" -- )  PARSE-WORD SHEADER ;
  33.  
  34. : CREATED ( addr u -- )
  35. \ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï c-addr u á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ®¯¨á ­­®© ­¨¦¥.
  36. \ …᫨ 㪠§ â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ­¥ ¢ë஢­¥­, § à¥§¥à¢¨à®¢ âì ¬¥áâ®
  37. \ ¤«ï ¢ëà ¢­¨¢ ­¨ï. ®¢ë© 㪠§ â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ®¯à¥¤¥«ï¥â
  38. \ ¯®«¥ ¤ ­­ëå name. CREATE ­¥ १¥à¢¨àã¥â ¬¥áâ® ¢ ¯®«¥ ¤ ­­ëå name.
  39. \ name ‚믮«­¥­¨¥: ( -- a-addr )
  40. \ a-addr -  ¤à¥á ¯®«ï ¤ ­­ëå name. ‘¥¬ ­â¨ª  ¢ë¯®«­¥­¨ï name ¬®¦¥â
  41. \ ¡ëâì à áè¨à¥­  á ¯®¬®éìî DOES>.
  42.   SHEADER
  43.   HERE DOES>A ! ( ¤«ï DOES )
  44.   CREATE-CODE COMPILE,
  45. ;
  46.  
  47. : CREATE ( "<spaces>name" -- ) \ 94
  48.    PARSE-WORD CREATED
  49. ;
  50.  
  51. : (DOES1) \ â  ç áâì, ª®â®à ï à ¡®â ¥â ®¤­®¢à¥¬¥­­® á CREATE (®¡ëç­®)
  52.   R> DOES>A @ CFL + -
  53.   DOES>A @ 1+ ! ;
  54.  
  55. Code (DOES2)
  56.    SUB  EBP, 4
  57.    MOV [EBP], EAX
  58.    POP  EBX
  59.    POP  EAX
  60.    PUSH EBX
  61.    RET
  62. EndCODE
  63.  
  64. : DOES>  \ 94
  65. \ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
  66. \ Š®¬¯¨«ïæ¨ï: ( C: clon-sys1 -- colon-sys2 )
  67. \ „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬ã
  68. \ ®¯à¥¤¥«¥­¨î. ã¤¥â ¨«¨ ­¥â ⥪ã饥 ®¯à¥¤¥«¥­¨¥ ᤥ« ­® ¢¨¤¨¬®
  69. \ ¤«ï ¯®¨áª  ¢ á«®¢ à¥ ¯à¨ ª®¬¯¨«ï樨 DOES>, § ¢¨á¨â ®â ॠ«¨§ æ¨¨.
  70. \ ®£«®é ¥â colon-sys1 ¨ ¯à®¨§¢®¤¨â colon-sys2. „®¡ ¢«ï¥â ᥬ ­â¨ªã
  71. \ ¨­¨æ¨ «¨§ æ¨¨, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î.
  72. \ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( -- ) ( R: nest-sys1 -- )
  73. \ ‡ ¬¥­¨âì ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï ¯®á«¥¤­¥£® ®¯à¥¤¥«¥­¨ï name, ­  ᥬ ­â¨ªã
  74. \ ¢ë¯®«­¥­¨ï name, ¤ ­­ãî ­¨¦¥. ‚®§¢à â¨âì ã¯à ¢«¥­¨¥ ¢ ¢ë§ë¢ î饥 ®¯à¥¤¥-
  75. \ «¥­¨¥, § ¤ ­­®¥ nest-sys1. ¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ name
  76. \ ­¥ ¡ë«® ®¯à¥¤¥«¥­® ç¥à¥§ CREATE ¨«¨ ®¯à¥¤¥«¥­­®¥ ¯®«ì§®¢ â¥«¥¬ á«®¢®,
  77. \ ¢ë§ë¢ î饥 CREATE.
  78. \ ˆ­¨æ¨ «¨§ æ¨ï: ( i*x -- i*x a-addr ) ( R: -- nest-sys2 )
  79. \ ‘®åà ­¨âì § ¢¨áïéãî ®â ॠ«¨§ æ¨¨ ¨­ä®à¬ æ¨î nest-sys2 ® ¢ë§ë¢ î饬
  80. \ ®¯à¥¤¥«¥­¨¨. ®«®¦¨âì  ¤à¥á ¯®«ï ¤ ­­ëå name ­  á⥪. «¥¬¥­âë á⥪ 
  81. \ i*x ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë name.
  82. \ name ‚믮«­¥­¨¥: ( i*x -- j*x )
  83. \ ‚믮«­¨âì ç áâì ®¯à¥¤¥«¥­¨ï, ª®â®à ï ­ ç¨­ ¥âáï á ᥬ ­â¨ª¨ ¨­¨æ¨ «¨§ æ¨¨,
  84. \ ¤®¡ ¢«¥­­®© DOES>, ª®â®à®¥ ¬®¤¨ä¨æ¨à®¢ «® name. «¥¬¥­âë á⥪  i*x ¨ j*x
  85. \ ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë ¨ १ã«ìâ âë á«®¢  name, ᮮ⢥âá⢥­­®.
  86.   ['] (DOES1) COMPILE,
  87.  ['] (DOES2) COMPILE,  \   ['] C-R>    MACRO,
  88. ; IMMEDIATE
  89.  
  90. : VOCABULARY ( "<spaces>name" -- )
  91. \ ‘®§¤ âì ᯨ᮪ á«®¢ á ¨¬¥­¥¬ name. ‚믮«­¥­¨¥ name § ¬¥­¨â ¯¥à¢ë© ᯨ᮪
  92. \ ¢ ¯®à浪¥ ¯®¨áª  ­  ᯨ᮪ á ¨¬¥­¥¬ name.
  93.  WORDLIST DUP
  94.  CREATE
  95.  ,
  96.  LATEST OVER CELL+ ! ( áá뫪  ­  ¨¬ï á«®¢ àï )
  97.  GET-CURRENT SWAP PAR! ( á«®¢ àì-¯à¥¤®ª )
  98. \ FORTH-WORDLIST SWAP CLASS! ( ª« áá )
  99.  VOC
  100.  ( DOES> ­¥ à ¡®â ¥â ¢ í⮬ –Š)
  101.  (DOES1) (DOES2) \ â ª ᤥ« « ¡ë DOES>, ®¯à¥¤¥«¥­­ë© ¢ëè¥
  102.  @ CONTEXT !
  103. ;
  104.  
  105. : VARIABLE ( "<spaces>name" -- ) \ 94
  106. \ à®¯ãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
  107. \ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ¤ ­­®© ­¨¦¥.
  108. \ ‡ à¥§¥à¢¨à®¢ âì ®¤­ã ï祩ªã ¯à®áâà ­á⢠ ¤ ­­ëå á ¢ë஢­¥­­ë¬  ¤à¥á®¬.
  109. \ name ¨á¯®«ì§ã¥âáï ª ª "¯¥à¥¬¥­­ ï".
  110. \ name ‚믮«­¥­¨¥: ( -- a-addr )
  111. \ a-addr -  ¤à¥á § à¥§¥à¢¨à®¢ ­­®© ï祩ª¨. ‡  ¨­¨æ¨ «¨§ æ¨î ï祩ª¨ ®â¢¥ç ¥â
  112. \ ¯à®£à ¬¬ 
  113.  CREATE
  114.  0 ,
  115. ;
  116. : CONSTANT ( x "<spaces>name" -- ) \ 94
  117. \ à®¯ãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
  118. \ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ¤ ­­®© ­¨¦¥.
  119. \ name ¨á¯®«ì§ã¥âáï ª ª "ª®­áâ ­â ".
  120. \ name ‚믮«­¥­¨¥: ( -- x )
  121. \ ®«®¦¨âì x ­  á⥪.
  122.  HEADER
  123.  CONSTANT-CODE COMPILE, ,
  124. ;
  125. : VALUE ( x "<spaces>name" -- ) \ 94 CORE EXT
  126. \ à®¯ãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬. ‘®§¤ âì
  127. \ ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ®¯à¥¤¥«¥­­®© ­¨¦¥, á ­ ç «ì­ë¬
  128. \ §­ ç¥­¨¥¬ à ¢­ë¬ x.
  129. \ name ¨á¯®«ì§ã¥âáï ª ª "§­ ç¥­¨¥".
  130. \ ‚믮«­¥­¨¥: ( -- x )
  131. \ ®«®¦¨âì x ­  á⥪. ‡­ ç¥­¨¥ x - â®, ª®â®à®¥ ¡ë«® ¤ ­®, ª®£¤  ¨¬ï ᮧ¤ ¢ «®áì,
  132. \ ¯®ª  ­¥ ¨á¯®«­¨âáï äà §  x TO name, § ¤ ¢ ­®¢®¥ §­ ç¥­¨¥ x,
  133. \  áá®æ¨¨à®¢ ­­®¥ á name.
  134.  HEADER
  135.  CONSTANT-CODE COMPILE, ,
  136.  TOVALUE-CODE COMPILE,
  137. ;
  138. : VECT ( -> )
  139.  ( ᮧ¤ âì á«®¢®, ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï ª®â®à®£® ¬®¦­® ¬¥­ïâì,
  140.    § ¯¨áë¢ ï ¢ ­¥£® ­®¢ë© xt ¯® TO)
  141.  HEADER
  142.  VECT-CODE COMPILE, ['] NOOP ,
  143.   TOVALUE-CODE COMPILE,
  144. ;
  145.  
  146. : ->VARIABLE ( x "<spaces>name" -- ) \ 94
  147.   HEADER
  148.   CREATE-CODE COMPILE,
  149.   ,
  150. ;
  151.  
  152. : USER-ALIGNED ( -- a-addr n )
  153.    USER-HERE 3 + 2 RSHIFT ( 4 / ) 4 * DUP
  154.    USER-HERE -
  155. ;
  156.  
  157. : USER-CREATE ( "<spaces>name" -- )
  158.   HEADER
  159.   HERE DOES>A ! ( ¤«ï DOES )
  160.   USER-CODE COMPILE,
  161.   USER-ALIGNED
  162.   USER-ALLOT  ,
  163. ;
  164. : USER ( "<spaces>name" -- ) \ «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¯®â®ª 
  165.   USER-CREATE
  166.   4 USER-ALLOT
  167. ;
  168.  
  169. ' _TOUSER-VALUE-CODE TO TOUSER-VALUE-CODE
  170.  
  171. : USER-VALUE ( "<spaces>name" -- ) \ 94 CORE EXT
  172.  HEADER
  173.  USER-VALUE-CODE COMPILE,
  174.  USER-ALIGNED SWAP ,
  175.  CELL+ USER-ALLOT
  176.  TOUSER-VALUE-CODE COMPILE,
  177. ;
  178.  
  179. : ->VECT ( x -> )
  180.  HEADER
  181.  VECT-CODE COMPILE, ,
  182.  TOVALUE-CODE COMPILE,
  183. ;
  184.  
  185. : : _: ;
  186.  
  187. : _: ( C: "<spaces>name" -- colon-sys ) \ 94
  188. \ à®¯ãáâ¨âì ¢¥¤ã騥 à §¤¥«¨â¥«¨. ‚뤥«¨âì ¨¬ï, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
  189. \ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï ¨¬¥­¨, ­ §ë¢ ¥¬®¥ "®¯à¥¤¥«¥­¨¥ ç¥à¥§ ¤¢®¥â®ç¨¥".
  190. \ “áâ ­®¢¨âì á®áâ®ï­¨¥ ª®¬¯¨«ï樨 ¨ ­ ç âì ⥪ã饥 ®¯à¥¤¥«¥­¨¥, ¯®«ã稢
  191. \ colon-sys. „®¡ ¢¨âì ᥬ ­â¨ªã ¨­¨æ¨ «¨§ æ¨¨, ®¯¨á ­­ãî ­¨¦¥, ¢ ⥪ã饥
  192. \ ®¯à¥¤¥«¥­¨¥. ‘¥¬ ­â¨ª  ¢ë¯®«­¥­¨ï ¡ã¤¥â ®¯à¥¤¥«¥­  á«®¢ ¬¨, ᪮¬¯¨«¨à®-
  193. \ ¢ ­­ë¬¨ ¢ ⥫® ®¯à¥¤¥«¥­¨ï. ’¥ªã饥 ®¯à¥¤¥«¥­¨¥ ¤®«¦­® ¡ëâì ­¥¢¨¤¨¬®
  194. \ ¯à¨ ¯®¨áª¥ ¢ á«®¢ à¥ ¤® â¥å ¯®à, ¯®ª  ­¥ ¡ã¤¥â § ¢¥à襭®.
  195. \ ˆ­¨æ¨ «¨§ æ¨ï: ( i*x -- i*x ) ( R: -- nest-sys )
  196. \ ‘®åà ­¨âì ¨­ä®à¬ æ¨î nest-sys ® ¢ë§®¢¥ ®¯à¥¤¥«¥­¨ï. ‘®áâ®ï­¨¥ á⥪ 
  197. \ i*x ¯à¥¤áâ ¢«ï¥â  à£ã¬¥­âë ¨¬¥­¨.
  198. \ ˆ¬ï ‚믮«­¥­¨¥: ( i*x -- j*x )
  199. \ ‚믮«­¨âì ®¯à¥¤¥«¥­¨¥ ¨¬¥­¨. ‘®áâ®ï­¨ï á⥪  i*x ¨ j*x ¯à¥¤áâ ¢«ïîâ
  200. \  à£ã¬¥­âë ¨ १ã«ìâ âë ¨¬¥­¨ ᮮ⢥âá⢥­­®.
  201.  PARSE-WORD _SHEADER ]
  202.  HERE TO :-SET
  203. ;
  204.  
  205. \ S" ~mak\CompIF.f" INCLUDED
  206.  
  207.