kolibrios-fun/programs/develop/SPForth/src/compiler/spf_defwords.f

( Ž¯à¥¤¥«ïî騥 á«®¢ , ᮧ¤ î騥 á«®¢ à­ë¥ áâ âì¨ ¢ á«®¢ à¥.
  Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
  Copyright [C] 1992-1999 A.Cherezov ac@forth.org
  <EFBFBD>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
  <EFBFBD>¥¢¨§¨ï - ᥭâï¡àì 1999
)

USER LAST-CFA
USER-VALUE LAST-NON

: REVEAL ( --- )
\ Add the last created definition to the CURRENT wordlist.
  LAST @ CURRENT @ ! ;

: SHEADER ( addr u -- )
  _SHEADER  REVEAL
;

: _SHEADER ( addr u -- )
  0 C,     ( flags )
  HERE 0 , ( cfa )
  DUP LAST-CFA !
  -ROT  WARNING @
  IF 2DUP GET-CURRENT SEARCH-WORDLIST
     IF DROP 2DUP TYPE ."  isn't unique" CR THEN
  THEN
  CURRENT @ SWORD,
  ALIGN
  HERE SWAP ! ( § ¯®«­¨«¨ cfa )
;

: HEADER ( "name" -- )  PARSE-WORD SHEADER ;

: CREATED ( addr u -- )
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï c-addr u á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ®¯¨á ­­®© ­¨¦¥.
\ …᫨ 㪠§ â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ­¥ ¢ë஢­¥­, § à¥§¥à¢¨à®¢ âì ¬¥áâ®
\ ¤«ï ¢ëà ¢­¨¢ ­¨ï. <20>®¢ë© 㪠§ â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ®¯à¥¤¥«ï¥â
\ ¯®«¥ ¤ ­­ëå name. CREATE ­¥ १¥à¢¨àã¥â ¬¥áâ® ¢ ¯®«¥ ¤ ­­ëå name.
\ name ‚믮«­¥­¨¥: ( -- a-addr )
\ a-addr -  ¤à¥á ¯®«ï ¤ ­­ëå name. ‘¥¬ ­â¨ª  ¢ë¯®«­¥­¨ï name ¬®¦¥â
\ ¡ëâì à áè¨à¥­  á ¯®¬®éìî DOES>.
  SHEADER
  HERE DOES>A ! ( ¤«ï DOES )
  CREATE-CODE COMPILE,
;

: CREATE ( "<spaces>name" -- ) \ 94
   PARSE-WORD CREATED
;

: (DOES1) \ â  ç áâì, ª®â®à ï à ¡®â ¥â ®¤­®¢à¥¬¥­­® á CREATE (®¡ëç­®)
  R> DOES>A @ CFL + -
  DOES>A @ 1+ ! ;

Code (DOES2)
   SUB  EBP, 4
   MOV [EBP], EAX
   POP  EBX
   POP  EAX
   PUSH EBX
   RET
EndCODE

: DOES>  \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ Š®¬¯¨«ïæ¨ï: ( C: clon-sys1 -- colon-sys2 )
\ „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬ã
\ ®¯à¥¤¥«¥­¨î. <20>㤥⠨«¨ ­¥â ⥪ã饥 ®¯à¥¤¥«¥­¨¥ ᤥ« ­® ¢¨¤¨¬®
\ ¤«ï ¯®¨áª  ¢ á«®¢ à¥ ¯à¨ ª®¬¯¨«ï樨 DOES>, § ¢¨á¨â ®â ॠ«¨§ æ¨¨.
\ <20>®£«®é ¥â colon-sys1 ¨ ¯à®¨§¢®¤¨â colon-sys2. „®¡ ¢«ï¥â ᥬ ­â¨ªã
\ ¨­¨æ¨ «¨§ æ¨¨, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î.
\ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( -- ) ( R: nest-sys1 -- )
\ ‡ ¬¥­¨âì ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï ¯®á«¥¤­¥£® ®¯à¥¤¥«¥­¨ï name, ­  ᥬ ­â¨ªã
\ ¢ë¯®«­¥­¨ï name, ¤ ­­ãî ­¨¦¥. ‚®§¢à â¨âì ã¯à ¢«¥­¨¥ ¢ ¢ë§ë¢ î饥 ®¯à¥¤¥-
\ «¥­¨¥, § ¤ ­­®¥ nest-sys1. <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ name
\ ­¥ ¡ë«® ®¯à¥¤¥«¥­® ç¥à¥§ CREATE ¨«¨ ®¯à¥¤¥«¥­­®¥ ¯®«ì§®¢ â¥«¥¬ á«®¢®,
\ ¢ë§ë¢ î饥 CREATE.
\ ˆ­¨æ¨ «¨§ æ¨ï: ( i*x -- i*x a-addr ) ( R: -- nest-sys2 )
\ ‘®åà ­¨âì § ¢¨áïéãî ®â ॠ«¨§ æ¨¨ ¨­ä®à¬ æ¨î nest-sys2 ® ¢ë§ë¢ î饬
\ ®¯à¥¤¥«¥­¨¨. <20>®«®¦¨âì  ¤à¥á ¯®«ï ¤ ­­ëå name ­  á⥪. <20>«¥¬¥­âë á⥪ 
\ i*x ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë name.
\ name ‚믮«­¥­¨¥: ( i*x -- j*x )
\ ‚믮«­¨âì ç áâì ®¯à¥¤¥«¥­¨ï, ª®â®à ï ­ ç¨­ ¥âáï á ᥬ ­â¨ª¨ ¨­¨æ¨ «¨§ æ¨¨,
\ ¤®¡ ¢«¥­­®© DOES>, ª®â®à®¥ ¬®¤¨ä¨æ¨à®¢ «® name. <20>«¥¬¥­âë á⥪  i*x ¨ j*x
\ ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë ¨ १ã«ìâ âë á«®¢  name, ᮮ⢥âá⢥­­®.
  ['] (DOES1) COMPILE,
  ['] (DOES2) COMPILE,  \   ['] C-R>    MACRO, 
; IMMEDIATE

: VOCABULARY ( "<spaces>name" -- )
\ ‘®§¤ âì ᯨ᮪ á«®¢ á ¨¬¥­¥¬ name. ‚믮«­¥­¨¥ name § ¬¥­¨â ¯¥à¢ë© ᯨ᮪
\ ¢ ¯®à浪¥ ¯®¨áª  ­  ᯨ᮪ á ¨¬¥­¥¬ name.
  WORDLIST DUP
  CREATE
  ,
  LATEST OVER CELL+ ! ( áá뫪  ­  ¨¬ï á«®¢ àï )
  GET-CURRENT SWAP PAR! ( á«®¢ àì-¯à¥¤®ª )
\  FORTH-WORDLIST SWAP CLASS! ( ª« áá )
  VOC
  ( DOES> ­¥ à ¡®â ¥â ¢ í⮬ –Š)
  (DOES1) (DOES2) \ â ª ᤥ« « ¡ë DOES>, ®¯à¥¤¥«¥­­ë© ¢ëè¥
  @ CONTEXT !
;

: VARIABLE ( "<spaces>name" -- ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ¤ ­­®© ­¨¦¥.
\ ‡ à¥§¥à¢¨à®¢ âì ®¤­ã ï祩ªã ¯à®áâà ­á⢠ ¤ ­­ëå á ¢ë஢­¥­­ë¬  ¤à¥á®¬.
\ name ¨á¯®«ì§ã¥âáï ª ª "¯¥à¥¬¥­­ ï".
\ name ‚믮«­¥­¨¥: ( -- a-addr )
\ a-addr -  ¤à¥á § à¥§¥à¢¨à®¢ ­­®© ï祩ª¨. ‡  ¨­¨æ¨ «¨§ æ¨î ï祩ª¨ ®â¢¥ç ¥â 
\ ¯à®£à ¬¬ 
  CREATE
  0 ,
;
: CONSTANT ( x "<spaces>name" -- ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ¤ ­­®© ­¨¦¥.
\ name ¨á¯®«ì§ã¥âáï ª ª "ª®­áâ ­â ".
\ name ‚믮«­¥­¨¥: ( -- x )
\ <20>®«®¦¨âì x ­  á⥪.
  HEADER
  CONSTANT-CODE COMPILE, ,
;
: VALUE ( x "<spaces>name" -- ) \ 94 CORE EXT
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬. ‘®§¤ âì 
\ ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ®¯à¥¤¥«¥­­®© ­¨¦¥, á ­ ç «ì­ë¬ 
\ §­ ç¥­¨¥¬ à ¢­ë¬ x.
\ name ¨á¯®«ì§ã¥âáï ª ª "§­ ç¥­¨¥".
\ ‚믮«­¥­¨¥: ( -- x )
\ <20>®«®¦¨âì x ­  á⥪. ‡­ ç¥­¨¥ x - â®, ª®â®à®¥ ¡ë«® ¤ ­®, ª®£¤  ¨¬ï ᮧ¤ ¢ «®áì,
\ ¯®ª  ­¥ ¨á¯®«­¨âáï äà §  x TO name, § ¤ ¢ ­®¢®¥ §­ ç¥­¨¥ x, 
\  áá®æ¨¨à®¢ ­­®¥ á name.
  HEADER
  CONSTANT-CODE COMPILE, ,
  TOVALUE-CODE COMPILE,
;
: VECT ( -> )
  ( ᮧ¤ âì á«®¢®, ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï ª®â®à®£® ¬®¦­® ¬¥­ïâì,
    § ¯¨áë¢ ï ¢ ­¥£® ­®¢ë© xt ¯® TO)
  HEADER
  VECT-CODE COMPILE, ['] NOOP ,
  TOVALUE-CODE COMPILE,
;

: ->VARIABLE ( x "<spaces>name" -- ) \ 94
  HEADER
  CREATE-CODE COMPILE,
  ,
;

: USER-ALIGNED ( -- a-addr n )
   USER-HERE 3 + 2 RSHIFT ( 4 / ) 4 * DUP
   USER-HERE -
;

: USER-CREATE ( "<spaces>name" -- )
  HEADER
  HERE DOES>A ! ( ¤«ï DOES )
  USER-CODE COMPILE,
  USER-ALIGNED
  USER-ALLOT  ,
;
: USER ( "<spaces>name" -- ) \ «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¯®â®ª 
  USER-CREATE
  4 USER-ALLOT
;

' _TOUSER-VALUE-CODE TO TOUSER-VALUE-CODE

: USER-VALUE ( "<spaces>name" -- ) \ 94 CORE EXT
  HEADER
  USER-VALUE-CODE COMPILE,
  USER-ALIGNED SWAP ,
  CELL+ USER-ALLOT
  TOUSER-VALUE-CODE COMPILE,
;

: ->VECT ( x -> )
  HEADER
  VECT-CODE COMPILE, ,
  TOVALUE-CODE COMPILE,
;

: : _: ;

: _: ( C: "<spaces>name" -- colon-sys ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 à §¤¥«¨â¥«¨. ‚뤥«¨âì ¨¬ï, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï ¨¬¥­¨, ­ §ë¢ ¥¬®¥ "®¯à¥¤¥«¥­¨¥ ç¥à¥§ ¤¢®¥â®ç¨¥".
\ “áâ ­®¢¨âì á®áâ®ï­¨¥ ª®¬¯¨«ï樨 ¨ ­ ç âì ⥪ã饥 ®¯à¥¤¥«¥­¨¥, ¯®«ã稢
\ colon-sys. „®¡ ¢¨âì ᥬ ­â¨ªã ¨­¨æ¨ «¨§ æ¨¨, ®¯¨á ­­ãî ­¨¦¥, ¢ ⥪ã饥
\ ®¯à¥¤¥«¥­¨¥. ‘¥¬ ­â¨ª  ¢ë¯®«­¥­¨ï ¡ã¤¥â ®¯à¥¤¥«¥­  á«®¢ ¬¨, ᪮¬¯¨«¨à®-
\ ¢ ­­ë¬¨ ¢ ⥫® ®¯à¥¤¥«¥­¨ï. ’¥ªã饥 ®¯à¥¤¥«¥­¨¥ ¤®«¦­® ¡ëâì ­¥¢¨¤¨¬®
\ ¯à¨ ¯®¨áª¥ ¢ á«®¢ à¥ ¤® â¥å ¯®à, ¯®ª  ­¥ ¡ã¤¥â § ¢¥à襭®.
\ ˆ­¨æ¨ «¨§ æ¨ï: ( i*x -- i*x ) ( R: -- nest-sys )
\ ‘®åà ­¨âì ¨­ä®à¬ æ¨î nest-sys ® ¢ë§®¢¥ ®¯à¥¤¥«¥­¨ï. ‘®áâ®ï­¨¥ á⥪ 
\ i*x ¯à¥¤áâ ¢«ï¥â  à£ã¬¥­âë ¨¬¥­¨.
\ ˆ¬ï ‚믮«­¥­¨¥: ( i*x -- j*x )
\ ‚믮«­¨âì ®¯à¥¤¥«¥­¨¥ ¨¬¥­¨. ‘®áâ®ï­¨ï á⥪  i*x ¨ j*x ¯à¥¤áâ ¢«ïîâ
\  à£ã¬¥­âë ¨ १ã«ìâ âë ¨¬¥­¨ ᮮ⢥âá⢥­­®.
  PARSE-WORD _SHEADER ]
  HERE TO :-SET
;

\ S" ~mak\CompIF.f" INCLUDED