home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / meta86.seq < prev    next >
Encoding:
Text File  |  1991-02-28  |  22.7 KB  |  689 lines
  1. \ META86.SEQ    The META compiler Source for F-PC.
  2. \  F-PC : Forth-83 with separated heads, handles, and sequential files.
  3. \  Meta compiler.  Loaded by F-PC to produce KERNEL.COM.
  4.  
  5. \ *************************************************************
  6. \ ***      ORIGINALLY   Based on F83 version 2.1.0 by       ***
  7. \ ***                                                       ***
  8. \ ***    Henry Laxen         and    Michael Perry           ***
  9. \ ***    1259 Cornell Avenue        1125 Bancroft Way       ***
  10. \ ***    Berkeley, California       Berkeley, California    ***
  11. \ ***    94706                      94702                   ***
  12. \ ***                                                       ***
  13. \ *************************************************************
  14. \     Heads separation by:     J. D. Hopper
  15. \                              P.O. Box 2782
  16. \                              Stanford, Ca.  94305
  17.  
  18. \     Handles and
  19. \     sequential files by:      Tom Zimmer          Hm  (408) 263-8859
  20. \                               292 Falcato Drive   Wk  (408) 432-4643
  21. \                               Milpitas, Ca. 95035
  22.  
  23. \     Direct Threaded Code
  24. \     conversion by:            Bob Smith and Tom Zimmer
  25. \
  26. \               Contact:        Tom Zimmer          Hm  (408) 263-8859
  27. \                               292 Falcato Drive   Wk  (408) 432-4643
  28. \                               Milpitas, Ca. 95035
  29.  
  30. DECIMAL
  31.  
  32. 0COMPILER
  33.  
  34. WARNING OFF
  35. ONLY FORTH ALSO DEFINITIONS
  36.  
  37. 15 TABSIZE !    \ WIDER TABS
  38. 78 RMARGIN !    \ WIDER RIGHT MARGIN
  39.  0 LMARGIN !    \ LEFT MARGIN TO LEFT EDGE
  40. ?DARK           \ CLEAR SCREEN AND CLEAR #LINE
  41.  
  42. : .TITLE        CR
  43.                 ." Meta Compiled Direct Threaded Forth       "
  44.                 .DATE TAB .TIME
  45.                 CR CR ;
  46.  
  47. ONLY FORTH ALSO VOCABULARY META META ALSO META DEFINITIONS
  48.  
  49. VARIABLE SEG-Y
  50. VARIABLE SEG-X
  51. VARIABLE SEG-C
  52. VARIABLE SEG-S
  53.  
  54. : ZSAVE ( Addr len | filename -- ) \ Save code from external segment.
  55.         seqhandle+         !HCB
  56.         seqhandle+         HDELETE     DROP
  57.         seqhandle+         HCREATE     ABORT" Save Create ERR!"
  58.         seqhandle+ SEG-C @ EXHWRITE 0= ABORT" Save Write  ERR!"
  59.         seqhandle+         HCLOSE      ABORT" Save Close  ERR!" ;
  60.  
  61. COMMENT:
  62.           The following constant controls how many threads will be created
  63.         in the target KERNEL.COM. The constant #TTHREADS MUST BE a binary
  64.         multiple of two (2) for the KERNEL.COM to function. Any binary
  65.         multiple of two between and including 2 and 128 is acceptable.
  66.  
  67.           Higher values of #TTHREADS produces a faster compiler, but
  68.         costs more memory. i.e. from 32 to 64 threads costs 512 bytes
  69.         of code space and increases compile performance by 10%.
  70.         Increasing the number of threads from 64 to 128 costs 1024 bytes
  71.         of code space, and increases compile performance by only 4.5%.
  72. COMMENT;
  73.  
  74.  64 CONSTANT #TTHREADS
  75.  
  76. : MEMCHK ABORT" Insufficient Memory" ;
  77.  
  78. : DOSVER 0 $030 BDOS $0FF AND ;
  79.  
  80. : DOSCHK  DOSVER 2 < ABORT" Must have DOS >=2" ;
  81.  
  82.  DOSCHK
  83.  
  84. $0FFF CONSTANT SIZESEGS
  85. $0800 CONSTANT HEADSEGS \ 800 hex is 32k decimal bytes
  86. $0800 CONSTANT LISTSEGS
  87. $0FFF CONSTANT CODESEGS \ MUST BE less than $1000 for math in KERNEL4 to work
  88.                         \ Create and erase the buffers
  89. HEADSEGS ALLOC 8 = MEMCHK NIP DUP SEG-Y ! 0 HEADSEGS $010 * 0 LFILL
  90. LISTSEGS ALLOC 8 = MEMCHK NIP DUP SEG-X ! 0 LISTSEGS $010 * 0 LFILL
  91. CODESEGS ALLOC 8 = MEMCHK NIP DUP SEG-C ! 0 CODESEGS $010 * 0 LFILL
  92.  
  93. \ Un-comment out the following line if you want kernel words sizes saved.
  94. \ SIZESEGS ALLOC 8 = MEMCHK NIP DUP SEG-S ! 0 SIZESEGS $010 * 0 LFILL
  95.  
  96. : NYTH ( cfa -- ythread) 512 / 2* ;
  97.  
  98. : ?NEWPAGE      ( --- )
  99.                 PRINTING @ 0= IF EXIT THEN
  100.                 #LINE @ 57 >
  101.                 IF      CR
  102.                         12 SP@ 1 TYPE DROP #LINE OFF
  103.                         CR .TITLE
  104.                 THEN    ;
  105.  
  106. VARIABLE LABELS         LABELS OFF      \ DEFAULT TO NOT DISPLAY MAP
  107.  
  108. : ?LABELS       ( --- )
  109.                 CR CR ." Do you want LABELS printed Y/N [N]? "
  110.                 KEY BL OR 'y' = DUP LABELS !
  111.                 IF      ." Y"
  112.                 ELSE    ." N"   THEN CR .TITLE TIME-RESET ;
  113.  
  114. ?LABELS
  115.  
  116. : ?BEHEADABLE   ( --- )
  117.                 cr beheadable
  118.                 if      ." Some words WILL BE HEADERLESS"
  119.                 else    ." NO words will be made headerless"
  120.                 then    cr cr ;
  121. ?BEHEADABLE
  122.  
  123. HANDLE SIZEHNDL         SIZEHNDL !HCB KERNEL.SIZ
  124.  
  125. : SIZE-SAVE     ( --- )                 \ save the CFA sizes file
  126.                 SEG-S @ 0= ?EXIT
  127.                 CR ." Saving 64k image of CFA sizes.."
  128.                 SIZEHNDL HCREATE ABORT" Could not create SIZE file"
  129.                 0 $FF00 SIZEHNDL SEG-S @ EXHWRITE $FF00 -
  130.                 ABORT" Write error to SIZE file"
  131.                 SIZEHNDL HCLOSE DROP CR ;
  132.  
  133. 3 CONSTANT BODY_SIZE                    \ SIZE OF BODY FIELD IN BYTES
  134.  
  135. : >BODY-T       ( A1 --- A2 )           \ Move to body of target
  136.                 BODY_SIZE + ;
  137.  
  138. VARIABLE DP-T
  139.  
  140. : [FORTH]        FORTH    ; IMMEDIATE
  141.  
  142. : [META]         META     ; IMMEDIATE
  143.  
  144. : [ASSEMBLER]    ASSEMBLER     ; IMMEDIATE
  145.  
  146. : SWITCH   ( -- )
  147.    NOOP    ( Context )   NOOP ( Current )
  148.    DOES>   @ +XSEG DUP 0 @L CONTEXT @   SWAP CONTEXT !   OVER 0 !L
  149.                    DUP 2 @L CURRENT @   SWAP CURRENT !   SWAP 2 !L  ;
  150.    SWITCH  ( Redefine itself )
  151.  
  152. : CS:     ( taddr -- taddr tseg ) SEG-C @ SWAP ;
  153.  
  154. : CS:ERASE ( A1 N1 --- )      >R CS: R> 0 LFILL ;
  155.  
  156. 0 CONSTANT TARGET-ORIGIN
  157. : THERE   ( taddr -- addr )   TARGET-ORIGIN +   ;
  158. : C@-T    ( taddr -- char )   THERE CS: C@L ;
  159. : @-T     ( taddr -- n )      THERE CS: @L  ;
  160. : C!-T    ( char taddr -- )   THERE CS: C!L ;
  161. : !-T     ( n taddr -- )      THERE CS: !L  ;
  162. : HERE-T  ( -- taddr )   DP-T @   ;
  163. : ALLOT-T ( n -- )       DP-T +!   ;
  164. : C,-T    ( char -- )   HERE-T C!-T   1 ALLOT-T   ;
  165. : ,-T     ( n -- )      HERE-T  !-T   2 ALLOT-T   ;
  166. : S,-T    ( addr len -- )
  167.    0 ?DO   COUNT C,-T   LOOP   DROP   ;
  168.  
  169. : ,"-T    ( | text" -- ) '"' PARSE  DUP C,-T  S,-T  ALIGN  ;
  170.  
  171. : XS:     ( taddr -- taddr tseg ) SEG-X @ SWAP ;
  172. VARIABLE DP-X           0 DP-X !
  173. VARIABLE DPSEG-X        SEG-X @ DPSEG-X !
  174.  
  175. : PARAGRAPH-X   ( N1 --- SEG-DELTA ) 15 + U16/ ;
  176. : >XREL         ( SEG OFFSET --- OFFSET )     \ RELATIVE TO SEG-X
  177.                 SWAP SEG-X @ - 16 * + ;
  178.  
  179. : C@-X    ( taddr -- char )   XS: C@L ;
  180. : @-X     ( taddr -- n )      XS: @L  ;
  181. : C!-X    ( char taddr -- )   XS: C!L ;
  182. : !-X     ( n taddr -- )      XS: !L  ;
  183. : HERE-X  ( -- XDPSEG taddr )   DPSEG-X @ DP-X @   ;
  184. : ALLOT-X ( n -- )       DP-X +!   ;
  185. : C,-X    ( char -- )   HERE-X C!L   1 ALLOT-X   ;
  186. : ,-X     ( n -- )      HERE-X  !L   2 ALLOT-X   ;
  187. : S,-X    ( addr len -- )
  188.         0 ?DO   COUNT C,-X   LOOP   DROP   ;
  189.  
  190. : ALIGN-X       ( --- )
  191.                 HERE-X NIP 1 AND IF 0 C,-X THEN ;
  192.  
  193. : YS:   SEG-Y @ SWAP ;
  194. VARIABLE DP-Y    256 DP-Y !
  195. : C@-Y    ( yaddr -- char )   YS: C@L  ;
  196. : @-Y     ( yaddr -- n )      YS: @L  ;
  197. : C!-Y    ( char yaddr -- )   YS: C!L ;
  198. : !-Y     ( n yaddr -- )      YS: !L  ;
  199. : HERE-Y  ( -- yaddr )        DP-Y @ ;
  200. : ALLOT-Y ( n -- )    DP-Y +! ;
  201. : C,-Y    ( char -- ) HERE-Y C!-Y  1 ALLOT-Y  ;
  202. : ,-Y     ( n -- )    HERE-Y  !-Y  2 ALLOT-Y  ;
  203. : S,-Y    ( addr len )  0 ?DO COUNT C,-Y  LOOP  DROP  ;
  204. : CSET-Y  ( byte yaddr -- )  TUCK C@-Y OR SWAP C!-Y ;
  205.  
  206. : SVXSEG        ( - xstart )
  207.                 SEG-X @ 0 SEG-C @ HERE-T  DUP >R THERE
  208.                 HERE-X PARAGRAPH-X + SEG-X @ - 16 *
  209.                 CMOVEL R> ;
  210.  
  211. : SVYSEG        ( - ystart )
  212.                 SEG-Y @ 0 SEG-C @ HERE-T  DUP >R THERE HERE-Y
  213.                 CMOVEL R> ;
  214.  
  215. : CNHASH ( CFA-YA )  $0FE00 AND FLIP ;
  216.  
  217. VARIABLE UNRESOLVED
  218.  
  219. : .UNRESOLVEPAUSE   ( --- )
  220.                 UNRESOLVED @
  221.                 IF      BEEP >NORM
  222.                         CR ." There were UNRESOLVED references,"
  223.                         CR >REV ." press a key to acknoledge." KEY DROP >NORM
  224.                         CR
  225.                 ELSE    >NORM ."  **** ALL REFERENCES RESOLVED **** "
  226.                 THEN    ;
  227.  
  228. VOCABULARY TARGET
  229. VOCABULARY TRANSITION
  230. VOCABULARY FORWARD
  231. VOCABULARY USER
  232.  
  233. ONLY DEFINITIONS FORTH ALSO META ALSO
  234.  
  235. : META          META  ;
  236. : TARGET        TARGET  ;
  237. : TRANSITION    TRANSITION  ;
  238. : FORWARD       FORWARD  ;
  239. : USER          USER    ;
  240. : ASSEMBLER     ASSEMBLER  ;
  241.  
  242. ONLY FORTH ALSO META ALSO DEFINITIONS
  243.  
  244. : X?>MARK       ( -- f addr )   TRUE   HERE-X NIP 0 ,-X   ;
  245. : X?>RESOLVE    ( f addr -- )   HERE-X -ROT SWAP !L   ?CONDITION  ;
  246. : X?<MARK       ( -- f addr )   TRUE   HERE-X NIP ;
  247. : X?<RESOLVE    ( f addr -- )   ,-X   ?CONDITION   ;
  248.  
  249. : AM?>MARK      ( -- f addr )   TRUE   HERE-T   0 C,-T   ;
  250. : AM?>RESOLVE   ( f addr -- )   HERE-T OVER 1+ - SWAP C!-T   ?CONDITION   ;
  251. : AM?<MARK      ( -- f addr )   TRUE   HERE-T   ;
  252. : AM?<RESOLVE   ( f addr -- )   HERE-T 1+ - C,-T   ?CONDITION   ;
  253.  
  254. '   C,-T        ASSEMBLER IS  C,
  255. '    ,-T        ASSEMBLER IS   ,
  256. '   C@-T        ASSEMBLER IS TC@
  257. '   C!-T        ASSEMBLER IS TC!
  258. ' HERE-T        ASSEMBLER IS HERE
  259. ' AM?>MARK      ASSEMBLER IS ?>MARK
  260. ' AM?>RESOLVE   ASSEMBLER IS ?>RESOLVE
  261. ' AM?<MARK      ASSEMBLER IS ?<MARK
  262. ' AM?<RESOLVE   ASSEMBLER IS ?<RESOLVE
  263.  
  264. : ?CLEAR-LABS   ( --- )
  265.                 [ ASSEMBLER ALSO FORTH ]
  266.                 LL-GLOBAL? 0=
  267.                 IF      LLAB-INIT               \ IN CASE LABELS USED
  268.                 THEN    ;
  269.  
  270. ONLY FORTH ALSO META ALSO DEFINITIONS
  271.  
  272. : SIZE-SET      ( --- )
  273.                 SEG-S @ 0= ?EXIT                \ leave if not saving sizes
  274.                 SEG-S @ DUP>R 0 @L              \ If non-zero then
  275.                 IF      HERE-T R@ 0 @L -        \ calculate actual length
  276.                         R@ DUP 0 @L !L          \ fill in CODE length WORD
  277.                         DP-X @                  \ length of list
  278.                         R@ DUP 0 @L 2+ !L       \ fill in LIST length WORD
  279.                         HERE-X PARAGRAPH-X + DPSEG-X ! DP-X OFF
  280.                                                 \ Round up LIST segment
  281.                 THEN    HERE-T R> 0 !L ;
  282.  
  283. : LABEL         ( | NAME -- )
  284.                 @> RUN =: ARUNSAVE
  285.                 0 ['] DROP A;!
  286.                 ['] RUN-A; IS RUN
  287.                 ASSEMBLER DEFINITIONS
  288.                 ?CLEAR-LABS
  289.                 >IN @ >R HERE-T CONSTANT
  290.                 LABELS @
  291.                 IF      R> >IN !
  292.                         BL WORD DUP C@ 5 + ?LINE
  293.                         HERE-T H.
  294.                         COUNT TYPE TAB
  295.                         ?NEWPAGE
  296.                 ELSE    R>DROP
  297.                 THEN    !CSP  ;
  298.  
  299. : XLABEL        ( | NAME -- )
  300.                 @> RUN =: ARUNSAVE
  301.                 0 ['] DROP A;!
  302.                 ['] RUN-A; IS RUN
  303.                 ASSEMBLER DEFINITIONS
  304.                 ?CLEAR-LABS
  305.                 >IN @ >R HERE-X >XREL CONSTANT
  306.                 LABELS @
  307.                 IF      R> >IN !
  308.                         BL WORD DUP C@ 5 + ?LINE
  309.                         HERE-T H.
  310.                         COUNT TYPE TAB
  311.                         ?NEWPAGE
  312.                 ELSE    R>DROP  THEN !CSP ;
  313.  
  314. : MAKE-CODE     ( PFA -- ) @ ,-X   ;                    \ Absolute address
  315. : MAKE-CODE-REL ( PFA -- ) @ HERE-T 2+ - ,-T   ;        \ Relative offset
  316.  
  317. : IN-TARGET     ( -- )          ONLY TARGET DEFINITIONS    ;
  318. : IN-TRANSITION ( -- )          ONLY FORWARD ALSO TARGET DEFINITIONS
  319.                                 ALSO TRANSITION    ;
  320. : IN-META       ( -- )          ONLY FORTH ALSO META DEFINITIONS ALSO  ;
  321. : IN-FORWARD    ( -- )          FORWARD DEFINITIONS    ;
  322. : LINK-BACKWARDS     ( PFA -- ) HERE-X >XREL OVER @ ,-X   SWAP !   ;
  323. : LINK-BACKWARDS-REL ( PFA -- ) HERE-T OVER @ ,-T   SWAP !   ;
  324. : RESOLVED?     ( pfa -- f )    2+ @   ;
  325.  
  326. : FORWARD-CODE  ( pfa -- )      DUP RESOLVED?
  327.                                 IF      MAKE-CODE
  328.                                 ELSE    LINK-BACKWARDS  THEN ;
  329.  
  330. : FORWARD-CODE-REL ( pfa -- )   DUP RESOLVED?
  331.                                 IF      MAKE-CODE-REL
  332.                                 ELSE    LINK-BACKWARDS-REL  THEN ;
  333.  
  334. : FORWARD:      ( -- )
  335.                 SWITCH   FORWARD DEFINITIONS
  336.                 CREATE SWITCH  0 , 0 , DOES>   FORWARD-CODE   ;
  337.  
  338. : FORWARD_REL:  ( -- )
  339.                 SWITCH   FORWARD DEFINITIONS
  340.                 CREATE SWITCH  0 , 0 , DOES>   FORWARD-CODE-REL ;
  341.  
  342. VARIABLE LAST-T
  343. VARIABLE CONTEXT-T
  344. VARIABLE CURRENT-T
  345.  
  346. VARIABLE WIDTH-T        31 WIDTH-T !
  347. VARIABLE WIDTH-SAVE     31 WIDTH-SAVE !
  348.  
  349. \ Use the normal HWORDS+ and HWORDS- to enable and disable the BEHEAD
  350. \ mechanism.  Use HEADERLESS and HEADERS as you would in regular Forth.
  351. \ BEHEAD while available is not needed in the meta compiler.
  352.  
  353. : HEADERLESS    ( --- )         \ disable generation of headers starting here
  354.                 beheadable WIDTH-T @ and
  355.                 if      WIDTH-T @ WIDTH-SAVE !
  356.                         WIDTH-T OFF
  357.                 then    ;
  358.  
  359. : HEADERS       ( --- )         \ re-enable the generation of headers here
  360.                 beheadable
  361.                 if      WIDTH-SAVE @ WIDTH-T !
  362.                 then    ;
  363.  
  364. : BEHEAD        ( --- ) ;       \ does NOTHING in the meta compiler
  365.  
  366. : HASH          ( str-addr voc-addr -- thread )
  367.                 SWAP
  368.                 DUP C@ SWAP 1+ DUP C@ 2* SWAP 1+ C@ + 2* +
  369.                 #TTHREADS 1- AND 2* +   ;
  370.  
  371. : HEADER        ( -- )
  372.                 BL WORD C@ 1+ WIDTH-T @ MIN   ?DUP
  373.         IF      ( HERE-Y 2- )   ( for ylink at end)
  374.                 ALIGN
  375.                 HERE-Y 2- @-Y CNHASH HERE-T CNHASH <> IF
  376.                 HERE-Y HERE-T CNHASH !-Y THEN  ( >NAME hash entry )
  377.                 LOADLINE @ ,-Y
  378.                 HERE CURRENT-T @ HASH DUP @-T ,-Y ( link )
  379.                 HERE-Y 2- SWAP !-T      ( point voc thread to link field )
  380.                 HERE-Y HERE ROT S,-Y   ALIGN   DUP LAST-T !
  381.                 128 SWAP CSET-Y   128 HERE-Y 1- CSET-Y
  382.                 HERE-T ,-Y              ( cfa ptr )
  383.                 HERE-Y HERE-T CNHASH 2+ !-Y     ( stopper >NAME hash entry )
  384.         THEN    ;
  385.  
  386. : TARGET-CREATE ( -- )
  387.                 >IN @ HEADER DUP >IN !
  388.                 LABELS @
  389.                 IF      BL WORD DUP C@ 5 + ?LINE
  390.                         HERE-T H.
  391.                         COUNT TYPE TAB ?NEWPAGE
  392.                 THEN    >IN !
  393.                 IN-TARGET CREATE IN-META  HERE-T , TRUE ,
  394.                 SIZE-SET
  395.                 DOES>   MAKE-CODE   ;
  396.  
  397. : RECREATE      ( -- )  >IN @   TARGET-CREATE   >IN !   ;
  398.  
  399.  
  400. FORTH DEFINITIONS
  401.  
  402. : CODE          ( NAME --- )
  403.                 @> RUN =: ARUNSAVE
  404.                 0 ['] DROP A;!
  405.                 ['] RUN-A; IS RUN
  406.                 TARGET-CREATE ASSEMBLER ?CLEAR-LABS !CSP  ;
  407.  
  408. : INLINE        ( --- )
  409.                 @> RUN =: ARUNSAVE
  410.                 0 ['] DROP A;!
  411.                 ['] RUN-A; IS RUN
  412.                 ASSEMBLER ?CLEAR-LABS !CSP HERE-T ,-X ;
  413.  
  414.  
  415. ASSEMBLER ALSO DEFINITIONS
  416.  
  417. : END-CODE      [ FORTH ]
  418.                 ll-global? 0=
  419.                 if      ll-errs?        \ check for local label errors
  420.                 then
  421.                 ARUNSAVE IS RUN
  422.                 A; IN-META ?CSP  ;
  423.  
  424. : END-INLINE    [ FORTH ]
  425.                 ll-global? 0=
  426.                 if      ll-errs?        \ check for local label errors
  427.                 then
  428.                 ARUNSAVE IS RUN
  429.                 A; IN-META ?CSP  ;
  430.  
  431. : C;            [ FORTH ]
  432.                 ll-global? 0=
  433.                 if      ll-errs?        \ check for local label errors
  434.                 then
  435.                 ARUNSAVE IS RUN
  436.                 A; IN-META ?CSP  ;
  437.  
  438. META IN-META
  439.  
  440. : 'T            ( -- cfa )
  441.                 CONTEXT @   TARGET DEFINED   ROT CONTEXT !
  442.                 0= ?MISSING   ;
  443.  
  444. : [TARGET]      ( -- )          'T X, ;   IMMEDIATE
  445.  
  446. : 'F            ( -- cfa )
  447.                 CONTEXT @   FORWARD DEFINED   ROT CONTEXT !
  448.                 0= ?MISSING   ;
  449.  
  450. : [FORWARD]     ( -- )  'F X, ;   IMMEDIATE
  451.  
  452. : T:            ( -- )
  453.                 SWITCH  TRANSITION DEFINITIONS
  454.                 CREATE  XHERE PARAGRAPH + DUP XDPSEG ! XSEG @ - , XDP OFF
  455.                 SWITCH   ]
  456.                 DOES>   @ +XSEG >R 0 >R ;
  457.  
  458. : T;            ( -- )
  459.                 SWITCH   TRANSITION DEFINITIONS   [COMPILE] ;    SWITCH   ;
  460.                 IMMEDIATE
  461.  
  462. : DIGIT?        ( CHAR -- F )   BASE @ DIGIT NIP   ;
  463.  
  464. : PUNCT?        ( CHAR -- F )
  465.                 '.' OVER = SWAP   '-' OVER = SWAP
  466.                 '/' OVER = SWAP   DROP OR OR ;
  467.  
  468. : NUMERIC?      ( ADDR LEN -- F )
  469.                 BASE @ >R
  470.                 OVER C@ '$' =
  471.                 IF      1- SWAP 1+ SWAP HEX
  472.                 THEN    DUP 1 =
  473.                 IF      DROP C@ DIGIT?
  474.                 ELSE    1 -ROT   0 ?DO   DUP C@   DUP DIGIT? SWAP PUNCT? OR
  475.                         ROT AND SWAP 1+   LOOP   DROP
  476.                 THEN    R> BASE ! ;
  477.  
  478. T: (    [COMPILE] (     T;
  479. T: (    [COMPILE] (     T;
  480. T: \    [COMPILE] \     T;
  481.  
  482. : STRING,-T     ( -- )
  483.                 '"' PARSE  DUP C,-T  S,-T  ALIGN  ;
  484.  
  485. : STRING,-X     ( -- )
  486.                 '"' PARSE  DUP C,-X  S,-X  ALIGN-X ;
  487.  
  488.                 FORWARD: <(.")>
  489. T: ."           [FORWARD]  <(.")>  STRING,-X   T;
  490.  
  491.                 FORWARD: <(")>
  492. T: "            [FORWARD] <(")>    HERE-T ,-X STRING,-T   T;
  493.  
  494.                 FORWARD: <(ABORT")>
  495. T: ABORT"       [FORWARD] <(ABORT")> STRING,-X   T;
  496.  
  497.                 FORWARD_REL: <VARIABLE>
  498. : CREATE        RECREATE
  499.                 232 C,-T
  500.                 [FORWARD] <VARIABLE>   HERE-T CONSTANT   ;
  501.  
  502. : VARIABLE      ( | name -- ) CREATE   0 ,-T   ;
  503.  
  504.                 FORWARD_REL: <DEFER>
  505. : DEFER         ( -- )
  506.                 TARGET-CREATE
  507.                 232 C,-T                        \ CALL instruction
  508.                 [FORWARD] <DEFER>   0 ,-T   ;
  509.  
  510. FORTH
  511.  
  512. VARIABLE #USER-T
  513.  
  514. META ALSO USER DEFINITIONS
  515.  
  516. : ALLOT         ( n -- )
  517.                 #USER-T +!   ;
  518.  
  519.                 FORWARD_REL: <USER-VARIABLE>
  520. : VARIABLE      ( -- )
  521.                 SWITCH   RECREATE
  522.                 232 C,-T
  523.                 [FORWARD] <USER-VARIABLE>   #USER-T @
  524.                 DUP ,-T   2 ALLOT   META DEFINITIONS   CONSTANT   SWITCH   ;
  525.  
  526.                 FORWARD_REL: <USER-DEFER>
  527. : DEFER         ( -- )
  528.                 SWITCH   TARGET-CREATE
  529.                 232 C,-T
  530.                 [FORWARD] <USER-DEFER>   SWITCH
  531.                 #USER-T @ ,-T   2 ALLOT   ;
  532.  
  533. ONLY FORTH ALSO META ALSO DEFINITIONS
  534.  
  535. FORTH
  536. VARIABLE VOC-LINK-T
  537. VARIABLE PHEAD-T
  538. META
  539.  
  540.                 FORWARD_REL: <VOCABULARY>
  541. : VOCABULARY    ( -- )
  542.                 RECREATE
  543.                 232 C,-T                \ CALL instruction to DOVOC
  544.                 [FORWARD] <VOCABULARY>
  545.                 HERE-T   #TTHREADS 0 DO  0 ,-T  LOOP
  546.                 HERE-T VOC-LINK-T @ ,-T   VOC-LINK-T !
  547.                 CONSTANT DOES> @ CONTEXT-T !   ;
  548.  
  549.                 FORWARD_REL: <POINTER>
  550. : POINTER       ( d1 | name -- ) \ make a pointer of double d1 with name
  551.                 RECREATE
  552.                 232 C,-T                \ CALL instruction to DOPOINTER
  553.                 [FORWARD] <POINTER>
  554.                 HERE-T -ROT 0 ,-T
  555.                 HERE-T PHEAD-T @ ,-T PHEAD-T !
  556.                 15. D+
  557.                 D2/ D2/ D2/ D2/ DROP ,-T        \ compile paragraphs needed
  558.                 CONSTANT DOES> DROP
  559.                 TRUE ABORT" Can't use POINTERS interpretively" ;
  560.  
  561. : IMMEDIATE     ( -- )
  562.                 WIDTH-T @
  563.                 IF ( Headers present? )
  564.                 64 ( Precedence Bit )   LAST-T @   CSET-Y   THEN   ;
  565.  
  566. FORWARD: <(;USES)>
  567.  
  568. FORTH
  569.  
  570. VARIABLE STATE-T
  571.  
  572. META
  573.  
  574. T: ;USES        ( -- )
  575.                 [FORWARD] <(;USES)>   IN-META ASSEMBLER
  576.                 !CSP   STATE-T OFF   T;
  577.  
  578. T: [COMPILE]    'T EXECUTE    T;
  579.  
  580.                 FORWARD: <(IS)>
  581. T: IS           [FORWARD] <(IS)>    T;
  582. :  IS           'T  ( CR HERE COUNT TYPE TAB OVER H. )
  583.                 >BODY @ >BODY-T !-T ;
  584.  
  585. T: ALIGN   T;
  586.  
  587. T: EVEN    T;
  588.  
  589. : .SYMBOLS      ( -- )
  590.                 TARGET   CONTEXT @ HERE #TTHREADS 2* CMOVE  CR
  591.                 BEGIN   HERE 4 LARGEST  DUP
  592.                 WHILE   DUP L>NAME  DUP Y@ 31 AND 2+ ?LINE
  593.                         ."  /  "  DUP .ID
  594.                         NAME> >BODY @ U.
  595.                         Y@ SWAP !
  596.                         KEY? IF   EXIT   THEN
  597.                 REPEAT  2DROP   IN-META   ;
  598.  
  599. : .UNRESOLVED   ( -- )
  600.                 UNRESOLVED OFF
  601.                 FORWARD CONTEXT @ HERE #THREADS 2* CMOVE
  602.                 BEGIN   HERE #THREADS LARGEST   DUP
  603.                 WHILE   ?CR DUP L>NAME NAME> >BODY
  604.                         RESOLVED? 0=
  605.                         IF      >ATTRIB4 DUP L>NAME .ID >NORM SPACE
  606.                                 UNRESOLVED ON
  607.                         THEN
  608.                         Y@  SWAP !
  609.                 REPEAT  2DROP .UNRESOLVEPAUSE IN-META ;
  610.  
  611. : FIND-UNRESOLVED ( -- cfa f )  'F    DUP  >BODY RESOLVED?     ;
  612.  
  613. DECIMAL
  614.  
  615. : RESOLVE       ( taddr cfa -- )        \ resolve for CODE space
  616.                 >BODY   2DUP   TRUE OVER 2+ !   @
  617.                 BEGIN   DUP
  618.                 WHILE   2DUP @-T   -ROT SWAP
  619.                         DUP 1-  C@-T 232 =            \ IF PRECEEDED BY CALL
  620.                         IF      DUP 2+ ROT SWAP - SWAP \ SWITCH TO RELATIVE
  621.                         THEN    !-T
  622.                 REPEAT  2DROP  ! ;
  623.  
  624. : RESOLVES      ( taddr -- )
  625.                 FIND-UNRESOLVED
  626.                 IF      CR >NAME .ID ." Already Resolved" DROP
  627.                 ELSE    RESOLVE   THEN   ;
  628.  
  629. : :RESOLVE      ( taddr cfa -- )        \ resolve for LIST space
  630.                 >BODY   2DUP   TRUE OVER 2+ !   @
  631.                 BEGIN   DUP
  632.                 WHILE   2DUP @-X   -ROT SWAP !-X
  633.                 REPEAT  2DROP  ! ;
  634.  
  635. : :RESOLVES     ( taddr -- )
  636.                 FIND-UNRESOLVED
  637.                 IF      CR >NAME .ID ." Already Resolved" DROP
  638.                 ELSE    :RESOLVE   THEN   ;
  639.  
  640. : H:    [COMPILE] :   ;
  641.  
  642. H: '     'T >BODY @   ;
  643. H: ,    ,-T ;
  644. H: C,  C,-T ;
  645. H: X,   ,-X ;
  646. H: XC, C,-X ;
  647.  
  648. H: HERE         HERE-T ;
  649. H: XHERE        ( HERE-X ) TRUE ABORT" Used HERE-X" ;
  650. H: ALLOT        ALLOT-T   ;
  651. H: DEFINITIONS  DEFINITIONS   CONTEXT-T @ CURRENT-T !    ;
  652.  
  653. ONLY FORTH DEFINITIONS ALSO
  654.  
  655. .( Meta Compiler Loaded )
  656.  
  657. CR .ELAPSED CR
  658.  
  659. FLOAD KERNEL1.SEQ
  660. FLOAD VIDEO.SEQ
  661. FLOAD KERNEL2.SEQ
  662. FLOAD VIDEO2.SEQ
  663. FLOAD KERNEL3.SEQ
  664. FLOAD EXPAND.SEQ
  665. FLOAD EMMEXEC.SEQ
  666. FLOAD POINTER.SEQ
  667. FLOAD EQUCOLON.SEQ
  668. FLOAD SAVEREST.SEQ
  669. FLOAD HANDLES.SEQ
  670. FLOAD SEQREAD.SEQ
  671. FLOAD FPATH.SEQ
  672. FLOAD DEFAULT.SEQ
  673. FLOAD HCRITICA.SEQ
  674. FLOAD KERNEL4.SEQ       \ 05/25/90 tjz
  675.  
  676. ALSO META
  677.  
  678. SIZE-SAVE       \ Write the 64k image of CFA sizes to KERNEL.SIZ
  679.  
  680. PREVIOUS
  681.  
  682. CAPS ON
  683.  8 TABSIZE !    \ RESTORE TABS
  684. 70 RMARGIN !    \ RESTORE RIGHT MARGIN
  685. ?PAGE           \ NEW PAGE
  686. PRINTING OFF    \ NO PRINTING ANY MORE
  687. 0 24 AT           \ Go back there.
  688. CR CR
  689.