home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / zen / xlate.src < prev    next >
Text File  |  1990-01-25  |  17KB  |  656 lines
  1. \    ZEN 1.9  Forth to MASM translator
  2. \    C 1989 by Martin Tracy
  3.  
  4. \*   Last modified: 12.10.89 by MJT
  5.  
  6.  Notes:
  7.    1. Words may not be named as numbers.
  8.    2. Words may not be redefined.
  9.    3. Vocabularies are not supported.
  10.    4. ASSEMBLER copies until END-CODE
  11.    5. Reserved words are only recognized in all caps.
  12.    6. MHERE and MTHERE put label on a separate line.
  13.    8. ." yields the string  2,".",34,""
  14.    9. M\* should be more selective.
  15.  
  16. *\
  17.  
  18. \ Display the vocabularies in the search order.
  19. : ORDER   \ RESERVED
  20.    BASE @   HEX
  21.    CONTEXT  BEGIN  DUP @ WHILE  DUP @ U.  CELL+ REPEAT  DROP  BASE ! ;
  22.  
  23.  
  24. \ V O C A B U L A R I E S
  25.  
  26. \ Forth words with altered meaning go here.
  27. VOCABULARY MAGIC
  28.  
  29. \ Make these vocabularies IMMEDIATE:
  30. : [FORTH]   POSTPONE FORTH ;  IMMEDIATE
  31. : [MAGIC]   POSTPONE MAGIC ;  IMMEDIATE
  32.  
  33.  
  34. \ W R I T E   F I L E S
  35.  
  36. FILE TARGET   \ MASM  source file
  37. FILE VARFIL   \ variable intermediate file
  38. FILE DATFIL   \ create   intermediate file
  39.  
  40. \ Write string with guarantee.
  41. : F.WRITE ( a u fcb)
  42.    OVER >R  WRITE-FILE SWAP  R> - OR ABORT" Bad write" ;
  43.  
  44. \ Write end-of-line sequence with guarantee.
  45. : F.CR ( fcb)
  46.    CRLF COUNT  ROT F.WRITE ;
  47.  
  48. \ Write line with guarantee.
  49. : F.LINE ( a u fcb)
  50.    DUP >R  F.WRITE  R> F.CR ;
  51.  
  52.  
  53. \ W R I T E   T A R G E T
  54.  
  55. 80 CONSTANT #LEN   \ Maximum length of TARGET line
  56.  
  57. VARIABLE CTR   \ # of chars written to TARGET line
  58. VARIABLE DW?   \ true if dw field already written to TARGET line
  59. VARIABLE M\?   \ true if run of backslash comments in column zero
  60.  
  61. \ Write end-of-line sequence to TARGET.  Reset CTR DW?
  62. : T.CR
  63.    TARGET F.CR   CTR OFF  DW? OFF ;
  64.  
  65. \ Force TARGET to new line if necessary.
  66. : T.CR?
  67.    CTR @ IF  T.CR  THEN ;
  68.  
  69. \ Write string to TARGET and update CTR
  70. \ Force new line if this line would be too long.
  71. : T.WRITE ( a u)
  72. \  DUP CTR @ + #LEN > IF  T.CR  THEN
  73.    DUP CTR +!  TARGET F.WRITE ;
  74.  
  75. \ Write line to TARGET
  76. : T.LINE ( a u)
  77.    T.WRITE  T.CR ;
  78.  
  79. \ Write n spaces, up to 8 at a time.
  80. : T.SPACES ( +n)
  81.    8 /MOD  0 ?DO  "         "           T.WRITE  LOOP
  82.                   "         " DROP SWAP T.WRITE ;
  83.  
  84. \ Tab to  dw  field.
  85. : TAB1
  86.     8 CTR @ - 1 MAX T.SPACES ;
  87.  
  88.  
  89. \ C O P Y   L I N E S
  90.  
  91. \ Read next word, reading new source lines as needed.
  92. : NEXT.WORD ( ch - 'str)
  93.    BEGIN  DUP WORD  DUP C@ IF  NIP EXIT  THEN
  94.           INQUIRE
  95.    WHILE  DROP  REPEAT  NIP ;
  96.  
  97. \ Copy lines from SOURCE to TARGET,
  98. \ stopping at the first line beginning with the given string.
  99. : COPY.LINES ( a u)
  100.    BEGIN  INQUIRE
  101.    WHILE  BL WORD COUNT  2OVER COMPARE
  102.    WHILE  >IN OFF  ( Reread) 01 PARSE T.LINE
  103.    REPEAT THEN  2DROP ;
  104.  
  105. : ASSEMBLER
  106.    01 PARSE EVALUATE ( rest of line)
  107.    T.CR?  " END-CODE" COPY.LINES ;
  108.  
  109.  
  110. \ W R I T E   S Y M B O L S
  111.  
  112. : DW.TAB
  113.    TAB1  " dw    " T.WRITE  DW? ON ;
  114. : DB.TAB
  115.    TAB1  " db    " T.WRITE ;
  116. : EQ.TAB
  117.    TAB1  " EQU   " T.WRITE ;
  118.  
  119. \ Special formats:
  120. : 0####h ( n - a u)
  121.    BASE @ >R  HEX
  122.    0 <# [CHAR] h HOLD # # # # # #>  R> BASE ! ;
  123.  
  124. : (####h) ( n - a u)
  125.    BASE @ >R  HEX
  126.    0 <# [CHAR] ) HOLD [CHAR] h HOLD # # # # #
  127.         [CHAR] ( HOLD #>  R> BASE ! ;
  128.  
  129. : L#### ( n - a u)
  130.    BASE @ >R  HEX
  131.    0 <# # # # # [CHAR] L HOLD #>  R> BASE ! ;
  132.  
  133. : ##, ( n - a u)
  134.    BASE @ >R  DECIMAL
  135.    0 <# [CHAR] , HOLD # #S #>  R> BASE ! ;
  136.  
  137.  
  138. \ X L A T E   S Y M B O L S
  139.  
  140. VARIABLE JOT   80 CELL - ALLOT   \ temporary string buffer.
  141.  
  142. \ Imbed string in quotes.  Uses JOT
  143. : <QUOTED> ( a u - a2 u2)
  144.    >R  JOT R@ 2 + [CHAR] " FILL  JOT 1+ R@ CMOVE  JOT R> 2 + ;
  145.  
  146. \ Quote string and precede with count.
  147. : ##,QUOTED ( a u - a2 u2)
  148.    DUP ##,  2SWAP <QUOTED> STRCAT ;
  149.  
  150. \ Quote string and precede with count.
  151. \ Replace a single embedded quote with its ASCII equivalent.
  152. : DEQUOTED ( a u - a2 u2)
  153.    DUP ##,  2SWAP  2DUP [CHAR] " SCAN NIP  ?DUP
  154.    IF  OVER SWAP - >R   OVER R@ 1+ STRCPY
  155.        " ,34," STRCAT  2SWAP R> /STRING  STRCAT
  156.    THEN  <QUOTED> STRCAT ;
  157.  
  158. \ Append character to symbol on string stack:
  159. : Q+ ( a u - a2 u2)
  160.    " q" STRCAT ;
  161. : K+ ( a u - a2 u2)
  162.    " :" STRCAT ;
  163. : V+ ( a u - a2 u2)
  164.    " v" STRCAT ;
  165. : Z+ ( a u - a2 u2)
  166.    " z" STRCAT ;
  167.  
  168. \ Counted string array defining word.  See numerous examples.
  169. : SETS
  170.    CREATE ( n)             0 ?DO  BL WORD COUNT ",  LOOP
  171.    DOES> ( n - a u)  SWAP  0 ?DO  COUNT +           LOOP  COUNT ;
  172.  
  173.  8 SETS Ascii1A   Store Quote Sharp Dollar Percent Ampersand Tick LParen
  174.  7 SETS Ascii1B   RParen Star Plus Comma Minus Dot Slash
  175.  
  176. 10 SETS Numbers   Zero One Two Three Four Five Six Seven Eight Nine
  177.  
  178.  7 SETS Ascii2   Colon Semi Less Equals Great Query Fetch
  179.  
  180.  6 SETS Ascii3   LBracket Backslash RBracket Caret Uscore LTick
  181.  
  182.  4 SETS Ascii4   LCurly Bar RCurly Tilde
  183.  
  184.  
  185. \ Use C! to translate char into string.
  186. VARIABLE ONE.CHAR
  187.  
  188. \ Translate any non-printable chars into printable string
  189. : X.LETTER ( char - a u)
  190.    DUP [CHAR] 0 [CHAR] 9 1+ WITHIN
  191.        IF  [CHAR] 0 - Numbers  EXIT  THEN
  192.    DUP [CHAR] ! [CHAR] ( 1+ WITHIN
  193.        IF  [CHAR] ! - Ascii1A  EXIT  THEN
  194.    DUP [CHAR] ) [CHAR] / 1+ WITHIN
  195.        IF  [CHAR] ) - Ascii1B  EXIT  THEN
  196.    DUP [CHAR] : [CHAR] @ 1+ WITHIN
  197.        IF  [CHAR] : - Ascii2   EXIT  THEN
  198.    DUP [CHAR] [ [CHAR] ` 1+ WITHIN
  199.        IF  [CHAR] [ - Ascii3   EXIT  THEN
  200.    DUP [CHAR] { [CHAR] ~ 1+ WITHIN
  201.        IF  [CHAR] { - Ascii4   EXIT  THEN
  202.    ONE.CHAR C!  ONE.CHAR 1 ;
  203.  
  204. \ Reserved words.  Don't add spaces to end of line.
  205. : ResName
  206.    "  DUP ? ABS MOD AND OR XOR NOT BL TYPE ERR WORD DP " ;
  207. : ResName2
  208.    "  IF ELSE LEAVE LOOP WARN LOCAL PAGE ALIGN " ;
  209.  
  210. \ Translate reserved words by appending an underscore.
  211. \ True if reserved.
  212. : RESERVED? ( a u - a2 u2 f)
  213.    2DUP  ResName  2OVER STRNDX  0<
  214.    IF    ResName2 2OVER STRNDX  0< IF  2DROP 0  EXIT THEN
  215.    THEN  2DROP  " _" 2SWAP STRCAT  TRUE ;
  216.  
  217.  
  218. VARIABLE OLD.NAM1   32 CELL - ALLOT   \ original symbol name
  219. VARIABLE OLD.NAM2   32 CELL - ALLOT   \ original symbol name
  220. VARIABLE NEW.NAME  128 CELL - ALLOT   \ readable symbol name
  221.  
  222. \ Pseudo-vocabulary support:
  223. VARIABLE VOC#   \ 0 = Forth  1 = Root
  224.  
  225. : XFORTH   FORTH ;
  226.  
  227. : MFORTH   0 VOC# !  MAGIC ;
  228. : MROOT    1 VOC# ! ;
  229. : MDEFINITIONS   DEFINITIONS ;
  230.  
  231. : OLD.NAME
  232.    VOC# @ IF  OLD.NAM1  ELSE  OLD.NAM2  THEN ;
  233.  
  234. \ Translate string to readable string2 saved in NEW.NAME
  235. \ Reserved words need no further translation.
  236. : X.NAME ( a u - a2 u2)
  237.    RESERVED?
  238.    IF    NEW.NAME PLACE
  239.    ELSE  NEW.NAME 1+ SWAP  31 MIN 0
  240.      ?DO  OVER C@ X.LETTER ( len) >R
  241.           OVER R@ CMOVE  R> + SWAP 1+ SWAP
  242.      LOOP  NEW.NAME 1+ - 31 MIN NEW.NAME C!  DROP
  243.    THEN    NEW.NAME COUNT ;
  244.  
  245.  
  246.  
  247. \ T O K E N S
  248.  
  249. \ Add symbol to "dw" line.
  250. : DW+ ( a u)
  251.    DUP CTR @ + ( comma) 2 + #LEN > IF  T.CR  THEN
  252.    DW? @ NOT IF  DW.TAB  ELSE  " , " 2SWAP STRCAT  THEN
  253.    T.WRITE ;
  254.  
  255. \ Literals.
  256. : MLITERAL ( n)
  257.    " Lit, "  ROT 0####h STRCAT  DW+ ;
  258.  
  259. \ Address literals.
  260. : M[']
  261.    " Tic, "  BL WORD COUNT X.NAME STRCAT  DW+ ;
  262.  
  263. \ Words that look like numbers confuse the forward reference.
  264. : ResNumber
  265.    " 1+ 2+ 1- 2- 2/" ;
  266.  
  267. \ Like VAL? but single char non-digit punctuation "-" "." etc
  268. \ are not recognized as numbers.
  269. : MVAL? ( a u - d 2 , n 1 , 0)
  270.    DUP 1-
  271.    IF    2DUP ResNumber  2SWAP STRNDX 0<
  272.    ELSE  OVER C@  DUP  [CHAR] : =
  273.          SWAP [CHAR] , [CHAR] / 1+ WITHIN  OR NOT
  274.    THEN  IF  VAL?  ELSE  2DROP 0  THEN ;
  275.  
  276. \ Compile tokens and numbers.
  277. : DW, ( a u)
  278.    2DUP MVAL?  ?DUP
  279.    IF  1 = ( single precision?)
  280.        IF  MLITERAL  ELSE  SWAP MLITERAL MLITERAL  THEN  2DROP
  281.    ELSE  X.NAME DW+  THEN ;
  282.  
  283. \ Write label with colon to left of new target line.
  284. : LABEL: ( a u)
  285.    T.CR?  K+ T.WRITE ;
  286.  
  287.  
  288. \ H E A D E R S
  289.  
  290. VARIABLE LAST     \ last name field count byte
  291.   2 CELLS ALLOT   \ file location of last count byte
  292.                   \ Used by  MIMMEDIATE
  293.  
  294. \ Write link field.
  295. : LINK.FIELD ( a u)
  296.    T.CR?  T.WRITE  DW.TAB  OLD.NAME COUNT T.WRITE ;
  297.  
  298. \ Write name field.  Save info for possible IMMEDIATE
  299. : NAME.FIELD ( a u)
  300.    T.CR?  DB.TAB  TARGET FILEPOS LAST CELL+ 2!  DUP LAST !
  301.    DEQUOTED T.WRITE ;
  302.  
  303. VARIABLE T>IN   \ Remembers >IN for possible later TWINing.
  304.  
  305. \ Restores input stream to the position of the last header name.
  306. \ Input stream must be on the same line as before.
  307. : TWIN
  308.    T>IN @ >IN ! ;
  309.  
  310. VARIABLE MHEAD   \ True if header is to be compiled.
  311.  
  312. : M|   MHEAD OFF ;
  313.  
  314. \ Create link and name fields.
  315. : MHEADER
  316.    >IN @ T>IN ! ( possible reread)  M\? OFF
  317.    BL WORD COUNT   MHEAD @
  318.    IF  2DUP X.NAME Q+
  319.        2DUP LINK.FIELD  OLD.NAME PLACE  NAME.FIELD
  320.    ELSE  X.NAME 2DROP ( set NEW.NAME)  MHEAD ON  THEN ;
  321.  
  322. \ Mark a word as IMMEDIATE by altering its count byte.
  323. \ Headerless words must not be marked as IMMEDIATE.
  324. : MIMMEDIATE
  325.    TARGET FILEPOS  LAST CELL+ 2@   -1 TARGET SEEK-FILE  DROP 2DROP
  326.    LAST @ 32 + ##, TARGET F.WRITE  -1 TARGET SEEK-FILE  DROP 2DROP
  327.    T.CR?   " ; IMMEDIATE" T.LINE ;
  328.  
  329. \ Construct code field.
  330. \ String is normally macro name, eg ISCOLON
  331. : CODE.FIELD ( a u)
  332.    NEW.NAME COUNT LABEL:  TAB1  T.WRITE  T.CR ;
  333.  
  334.  
  335. \ H E R E  and  T H E R E
  336.  
  337. VARIABLE LABEL#   \ next label number
  338.  
  339. \ Unique label number.
  340. : NEW.LABEL# ( - n)
  341.    LABEL# @  1 LABEL# +! ;
  342.  
  343. \ Unique label string.
  344. : MAKE.LABEL ( - a u)
  345.    NEW.LABEL# L#### ;
  346.  
  347.  
  348. \ Next available variable location.
  349. : MTHERE ( - a u)
  350.    MAKE.LABEL  2DUP K+ VARFIL F.LINE ;
  351.  
  352. \ Next available table location.
  353. : MHERE ( - a u)
  354.    MAKE.LABEL  2DUP K+ DATFIL F.LINE ;
  355.  
  356.  
  357. \ Reserve n bytes in uninitialized variable file.
  358. : MALLOT ( n)
  359.    "         db    "  ROT (####h) STRCAT "  DUP (?)" STRCAT
  360.    VARFIL F.LINE ;
  361.  
  362. \ Add n to initialized data file.
  363. : MC, ( n)
  364.    "         db    "  ROT 0####h STRCAT  DATFIL F.LINE ;
  365. : M,  ( n)
  366.    "         dw    "  ROT 0####h STRCAT  DATFIL F.LINE ;
  367.  
  368.  
  369. \ D E F I N I N G   W O R D S
  370.  
  371. : MCODE
  372.    MHEADER  " " CODE.FIELD  ASSEMBLER ;
  373.  
  374. \ Create a constant whose value is a string.
  375. : $CONSTANT
  376.    CREATE  ( a u)    ",
  377.    DOES>   ( - a u)  COUNT ;
  378.  
  379. \ Factor of MLABEL and MVARIABLE
  380. : OD:$ ( a u)
  381.    " OFFSET DGROUP: " 2SWAP STRCAT
  382.     2DUP DW+  T.CR  TWIN $CONSTANT ;
  383.  
  384. \ Format a  dw ?  line beginning with the given label.
  385. : V.DW?.LINE ( a u - a2 u2)
  386.    DUP  "         " ROT - 1 MAX STRCAT  " dw    ?" STRCAT ;
  387.  
  388.  
  389. : MCREATE
  390.    MHEADER  " ISCREATE" CODE.FIELD  MHERE ( a u)
  391.    2DUP DW+  T.CR  TWIN $CONSTANT ;
  392.  
  393. \ Create a token whose value is a string.
  394. : MLABEL ( a u)
  395.    STRCPY ( protect from MHEADER)
  396.    MHEADER  " ISCONSTANT" CODE.FIELD   OD:$ ;
  397.  
  398. : MVARIABLE
  399.    MHEADER  " ISVARIABLE" CODE.FIELD
  400.    NEW.NAME COUNT V+  OD:$
  401.    NEW.NAME COUNT V+ V.DW?.LINE  VARFIL F.LINE ;
  402.  
  403. : MVALUE
  404.    MHEADER  " ISVALUE" CODE.FIELD
  405.    NEW.NAME COUNT V+  OD:$
  406.    NEW.NAME COUNT V+ V.DW?.LINE  VARFIL F.LINE ;
  407.  
  408. : M2VARIABLE
  409.    MVARIABLE  2 ( ie MCELL) MALLOT ;
  410.  
  411. : MVOCABULARY
  412.    MHEADER  " jmp   VOCABULARYqz" CODE.FIELD
  413.    NEW.NAME COUNT V+  " OFFSET DGROUP: " 2SWAP STRCAT DW+  T.CR
  414.    NEW.NAME COUNT V+ V.DW?.LINE  VARFIL F.LINE ;
  415.  
  416.  
  417. \ Headerless constant.
  418. : MEQU ( n)
  419.    CONSTANT ;
  420.  
  421. : MCONSTANT ( n)
  422.    MHEADER  " ISCONSTANT" CODE.FIELD
  423.    T.CR  DUP 0####h DW+ T.CR
  424.    TWIN CONSTANT ;
  425.  
  426.  
  427. \ C O M M E N T S
  428.  
  429. : MCOMMENT ( a u)
  430.    CTR @ IF "  ; " ELSE " ; " THEN
  431.    2SWAP STRCAT T.LINE ;
  432.  
  433. : M(
  434.    " ( " [CHAR] ) WORD COUNT STRCAT " ) " STRCAT MCOMMENT ;
  435. : M\
  436.    M\? @ 0= >IN @ 2 = AND IF  T.CR  M\? ON  THEN
  437.             >IN @ 2 =     IF  T.CR?         THEN
  438.    01 PARSE MCOMMENT ;
  439.  
  440. \ If not true, treat text as backslash comment.
  441. : M\IF ( f)
  442.    NOT IF  POSTPONE \   THEN ;
  443.  
  444. \ If not true, treat text as multi-line comment.
  445. : M\*IF ( f)
  446.    NOT IF  POSTPONE \*  THEN ;
  447.  
  448. : *\   ;
  449.  
  450.  
  451. \ F L O W   O F   C O N T R O L
  452.  
  453. \ Build branch to label.
  454. : BRANCH, ( n a u)
  455.    ROT L#### STRCAT DW+  T.CR ;
  456.  
  457. : MBRANCH  ( n)   " Branch, "   BRANCH, ;
  458. : MZBRANCH ( n)   " ZBranch, "  BRANCH, ;
  459.  
  460. \ Write numeric label with colon to left of new target line.
  461. : L####: ( n)
  462.   L#### LABEL: ;
  463.  
  464. VARIABLE bal   \ flow of control balance check
  465.  
  466. : huh?   0= ABORT" ??" ;
  467. : ?bal   bal @ < huh? ;
  468. : -bal   bal @   huh?  -1 bal +! ;
  469.  
  470. : MBEGIN   NEW.LABEL#  DUP L####:    1 bal +! ;
  471. : MIF      NEW.LABEL#  DUP MZBRANCH  1 bal +! ;
  472. : MTHEN   0 ?bal  -1 bal +!  L####: ;
  473. : MELSE   0 ?bal  NEW.LABEL#  DUP MBRANCH  SWAP L####: ;
  474.  
  475. : MAGAIN   -bal  MBRANCH ;
  476. : MUNTIL   -bal  MZBRANCH ;
  477. : MWHILE    bal @ huh?  MIF  SWAP ;
  478. : MREPEAT   1 ?bal  MAGAIN  MTHEN ;
  479.  
  480. VARIABLE LEAF   20 CELLS ALLOT   \ LEAVE label stack
  481. VARIABLE LP                      \ LEAVE stack pointer
  482.  
  483. : PUSHL ( n)     LP @ LEAF + !  CELL LP +! ;
  484. : COPYL ( - n)   LP @ CELL - LEAF + @ ;
  485. : POPL  ( - n)   COPYL   CELL NEGATE LP +! ;
  486.  
  487. \ Add LEAVE label to leaf string.
  488. : LEAVE.LABEL
  489.    NEW.LABEL# PUSHL ;
  490.  
  491. \ Resolve LEAVE label.
  492. : LEFT
  493.    POPL L####: ;
  494.  
  495.  
  496. : MDO
  497.    " RDo" DW+  MBEGIN  LEAVE.LABEL ;
  498. : M?DO
  499.    " QueryGreat" DW+   LEAVE.LABEL  COPYL MZBRANCH
  500.    " RDo" DW+  MBEGIN ;
  501.  
  502. : MLEAVE   " UNLOOP" dw+  COPYL MBRANCH ;
  503.  
  504. : MLOOP    -bal  " RLoop, " BRANCH,  LEFT ;
  505. : M+LOOP   -bal  " PLoop, " BRANCH,  LEFT ;
  506.  
  507.  
  508.  
  509. \ I N T E R P R E T  and  C O M P I L E
  510.  
  511. \ Search MAGIC only.  Only IMMEDIATE words are found.
  512. : MFIND ( 'str - cfa true | 'str 0)
  513.    DUP C@
  514.    IF  DUP [ ' MAGIC >BODY ] LITERAL @ THREAD  0>
  515.        IF  NIP TRUE  ELSE  DROP 0  THEN
  516.    ELSE  DROP  ['] EXIT TRUE  THEN ;
  517.  
  518. \ Compiler translator proper.
  519. : M]
  520.    BEGIN  BL NEXT.WORD MFIND
  521.       IF  EXECUTE  ELSE  COUNT DW,  THEN
  522.    AGAIN ;
  523.  
  524. : MTO
  525.    BL WORD COUNT X.NAME " +3" STRCAT DW+ ;
  526.  
  527.  
  528. \ C O L O N  and  S E M I C O L O N
  529.  
  530. : M:
  531.    MHEADER  " ISCOLON" CODE.FIELD
  532.    bal OFF  LP OFF   M] ;
  533.  
  534. : M;   bal @ ABORT" Unbalanced"  " EXIT" DW+  T.CR
  535.        2R> 2DROP ;
  536.  
  537. : M[   2R> 2DROP ;
  538.  
  539.  
  540. \ C O M P I L E R   S U P P O R T
  541.  
  542. : MDOES>
  543.    " PIPE" DW+
  544.    T.CR  OLD.NAME COUNT Z+ K+ T.WRITE
  545.    TAB1  " call  DoDoes" T.WRITE  T.CR ;
  546.  
  547.  
  548. : MPOSTPONE
  549.    BL WORD  DUP COUNT X.NAME  ROT MFIND  NIP
  550.    IF  ( [COMPILE])  DW+
  551.    ELSE ( COMPILE) " Tic, " 2SWAP STRCAT DW+
  552.       " XComma" DW+
  553.    THEN ;
  554.  
  555. : M[CHAR] ( - ch)
  556.    BL WORD 1+ C@ MLITERAL ;
  557.  
  558. \ Compile delimited counted string.
  559. : MSTRING ( ch)
  560.    "         db    " ROT WORD COUNT ##,QUOTED STRCAT
  561.    DATFIL F.LINE ;
  562.  
  563. : M" ( - a u)
  564.    " SLit" DW+  MHERE DW+  [CHAR] " MSTRING ;
  565.  
  566. : M."   M"  " _TYPE" DW+ ;
  567.  
  568. : MABORT"   MIF  M"  " _ERR" DW+  MTHEN ;
  569.  
  570.  
  571. \ I N T E R P R E T    A L I A S E S
  572.  
  573. : MDEFN
  574.    CREATE ' ,   DOES> PERFORM ;
  575.  
  576. MAGIC DEFINITIONS
  577. MDEFN IMMEDIATE MIMMEDIATE
  578. MDEFN HERE MHERE     MDEFN THERE MTHERE
  579. MDEFN ALLOT MALLOT   MDEFN ,  M,        MDEFN C,  MC,
  580. MDEFN CODE      MCODE
  581. MDEFN CREATE    MCREATE
  582. MDEFN CONSTANT  MCONSTANT
  583. MDEFN VARIABLE  MVARIABLE
  584. MDEFN 2VARIABLE M2VARIABLE
  585. MDEFN VALUE     MVALUE
  586. MDEFN EQU  MEQU      MDEFN LABEL MLABEL
  587. MDEFN \  M\          MDEFN (  M(
  588. MDEFN \IF  M\IF      MDEFN \*IF  M\*IF
  589. MDEFN ]  M]          MDEFN :  M:        MDEFN |  M|
  590. MDEFN VOCABULARY  MVOCABULARY
  591. MDEFN DEFINITIONS MDEFINITIONS
  592. MDEFN FORTH MFORTH   MDEFN ROOT MROOT
  593. XFORTH DEFINITIONS
  594.  
  595.  
  596. \ C O M P I L E R   A L I A S E S
  597.  
  598. : MCOMP   CREATE  ' ,  IMMEDIATE   DOES> PERFORM ;
  599.  
  600. MAGIC DEFINITIONS
  601. MCOMP BEGIN MBEGIN   MCOMP WHILE MWHILE   MCOMP REPEAT MREPEAT
  602. MCOMP UNTIL MUNTIL   MCOMP AGAIN MAGAIN
  603. MCOMP IF    MIF      MCOMP ELSE  MELSE    MCOMP THEN   MTHEN
  604. MCOMP DO    MDO      MCOMP LOOP  MLOOP    MCOMP +LOOP  M+LOOP
  605. MCOMP ?DO   M?DO
  606. MCOMP LEAVE MLEAVE   MCOMP LITERAL MLITERAL
  607. MCOMP \  M\          MCOMP (  M(
  608. MCOMP \IF   M\IF
  609. MCOMP [  M[          MCOMP ;  M;
  610. MCOMP "     M"       MCOMP ."    M."
  611. MCOMP [']   M[']     MCOMP POSTPONE MPOSTPONE
  612. MCOMP DOES>  MDOES>
  613. MCOMP [CHAR] M[CHAR]
  614. MCOMP ABORT" MABORT"
  615. MCOMP TO     MTO
  616. XFORTH DEFINITIONS
  617.  
  618.  
  619. \ T R A N S L A T E   F I L E S
  620.  
  621. \ Make file with guarantee.
  622. : FMUST.MAKE ( a u w fcb)
  623.    DUP >R  FMAKE NIP  R> SWAP
  624.    IF  FCB>N TYPE CR  TRUE ABORT" Can't make"  THEN  DROP ;
  625.  
  626. \ Translate one file by name.
  627. : SINGLE ( a u)
  628.    DECIMAL  DW? OFF  M\? OFF   MHEAD ON
  629.    2DUP " .INC" STRCAT R/W TARGET FMUST.MAKE
  630.    CR ." Including " 2DUP TYPE       MAGIC DEFINITIONS
  631.         " .SRC" STRCAT INCLUDE-FILE  FORTH DEFINITIONS
  632.    TARGET CLOSE-FILE DROP ;
  633.  
  634.  
  635. : MSTART
  636.    " VAR.INC" W/O VARFIL FMUST.MAKE
  637.    " TBL.INC" W/O DATFIL FMUST.MAKE
  638.    MROOT  " 0" OLD.NAME PLACE
  639.    MFORTH " 0" OLD.NAME PLACE  LABEL# OFF ;
  640.  
  641. : MFINIS
  642.    VARFIL CLOSE-FILE DROP
  643.    DATFIL CLOSE-FILE DROP ;
  644.  
  645. \ Translate all kernel files.
  646. : AUTO
  647.    MSTART
  648.    " INTERNAL" SINGLE
  649.    " CONTROL"  SINGLE     " STACKMEM" SINGLE
  650.    " LOGIMATH" SINGLE     " STRINGS"  SINGLE
  651.    " DEVICE"   SINGLE     " INPUTOUT" SINGLE
  652.    " INTRPRET" SINGLE     " COMPILER" SINGLE
  653.    " STRINGS2" SINGLE
  654.    " FILES"    SINGLE     " FINALE"   SINGLE
  655.    MFINIS  CR ;
  656.