home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / META86.SEQ < prev    next >
Encoding:
Text File  |  1989-09-21  |  22.0 KB  |  668 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. : XS:     ( taddr -- taddr tseg ) SEG-X @ SWAP ;
  170. VARIABLE DP-X           0 DP-X !
  171. VARIABLE DPSEG-X        SEG-X @ DPSEG-X !
  172.  
  173. : PARAGRAPH-X   ( N1 --- SEG-DELTA ) 15 + U16/ ;
  174. : >XREL         ( SEG OFFSET --- OFFSET )     \ RELATIVE TO SEG-X
  175.                 SWAP SEG-X @ - 16 * + ;
  176.  
  177. : C@-X    ( taddr -- char )   XS: C@L ;
  178. : @-X     ( taddr -- n )      XS: @L  ;
  179. : C!-X    ( char taddr -- )   XS: C!L ;
  180. : !-X     ( n taddr -- )      XS: !L  ;
  181. : HERE-X  ( -- XDPSEG taddr )   DPSEG-X @ DP-X @   ;
  182. : ALLOT-X ( n -- )       DP-X +!   ;
  183. : C,-X    ( char -- )   HERE-X C!L   1 ALLOT-X   ;
  184. : ,-X     ( n -- )      HERE-X  !L   2 ALLOT-X   ;
  185. : S,-X    ( addr len -- )
  186.         0 ?DO   COUNT C,-X   LOOP   DROP   ;
  187.  
  188. : ALIGN-X       ( --- )
  189.                 HERE-X NIP 1 AND IF 0 C,-X THEN ;
  190.  
  191. : YS:   SEG-Y @ SWAP ;
  192. VARIABLE DP-Y    256 DP-Y !
  193. : C@-Y    ( yaddr -- char )   YS: C@L  ;
  194. : @-Y     ( yaddr -- n )      YS: @L  ;
  195. : C!-Y    ( char yaddr -- )   YS: C!L ;
  196. : !-Y     ( n yaddr -- )      YS: !L  ;
  197. : HERE-Y  ( -- yaddr )        DP-Y @ ;
  198. : ALLOT-Y ( n -- )    DP-Y +! ;
  199. : C,-Y    ( char -- ) HERE-Y C!-Y  1 ALLOT-Y  ;
  200. : ,-Y     ( n -- )    HERE-Y  !-Y  2 ALLOT-Y  ;
  201. : S,-Y    ( addr len )  0 ?DO COUNT C,-Y  LOOP  DROP  ;
  202. : CSET-Y  ( byte yaddr -- )  TUCK C@-Y OR SWAP C!-Y ;
  203.  
  204. : SVXSEG        ( - xstart )
  205.                 SEG-X @ 0 SEG-C @ HERE-T  DUP >R THERE
  206.                 HERE-X PARAGRAPH-X + SEG-X @ - 16 *
  207.                 CMOVEL R> ;
  208.  
  209. : SVYSEG        ( - ystart )
  210.                 SEG-Y @ 0 SEG-C @ HERE-T  DUP >R THERE HERE-Y
  211.                 CMOVEL R> ;
  212.  
  213. : CNHASH ( CFA-YA )  $0FE00 AND FLIP ;
  214.  
  215. VARIABLE UNRESOLVED
  216.  
  217. : .UNRESOLVEPAUSE   ( --- )
  218.                 UNRESOLVED @
  219.                 IF      BEEP >NORM
  220.                         CR ." There were UNRESOLVED references,"
  221.                         CR >REV ." press a key to acknoledge." KEY DROP >NORM
  222.                         CR
  223.                 ELSE    >NORM ."  **** ALL REFERENCES RESOLVED **** "
  224.                 THEN    ;
  225.  
  226. VOCABULARY TARGET
  227. VOCABULARY TRANSITION
  228. VOCABULARY FORWARD
  229. VOCABULARY USER
  230.  
  231. ONLY DEFINITIONS FORTH ALSO META ALSO
  232.  
  233. : META          META  ;
  234. : TARGET        TARGET  ;
  235. : TRANSITION    TRANSITION  ;
  236. : FORWARD       FORWARD  ;
  237. : USER          USER    ;
  238. : ASSEMBLER     ASSEMBLER  ;
  239.  
  240. ONLY FORTH ALSO META ALSO DEFINITIONS
  241.  
  242. : X?>MARK       ( -- f addr )   TRUE   HERE-X NIP 0 ,-X   ;
  243. : X?>RESOLVE    ( f addr -- )   HERE-X -ROT SWAP !L   ?CONDITION  ;
  244. : X?<MARK       ( -- f addr )   TRUE   HERE-X NIP ;
  245. : X?<RESOLVE    ( f addr -- )   ,-X   ?CONDITION   ;
  246.  
  247. : AM?>MARK      ( -- f addr )   TRUE   HERE-T   0 C,-T   ;
  248. : AM?>RESOLVE   ( f addr -- )   HERE-T OVER 1+ - SWAP C!-T   ?CONDITION   ;
  249. : AM?<MARK      ( -- f addr )   TRUE   HERE-T   ;
  250. : AM?<RESOLVE   ( f addr -- )   HERE-T 1+ - C,-T   ?CONDITION   ;
  251.  
  252. '   C,-T        ASSEMBLER IS  C,
  253. '    ,-T        ASSEMBLER IS   ,
  254. '   C@-T        ASSEMBLER IS TC@
  255. '   C!-T        ASSEMBLER IS TC!
  256. ' HERE-T        ASSEMBLER IS HERE
  257. ' AM?>MARK      ASSEMBLER IS ?>MARK
  258. ' AM?>RESOLVE   ASSEMBLER IS ?>RESOLVE
  259. ' AM?<MARK      ASSEMBLER IS ?<MARK
  260. ' AM?<RESOLVE   ASSEMBLER IS ?<RESOLVE
  261.  
  262. : ?CLEAR-LABS   ( --- )
  263.                 [ ASSEMBLER ALSO FORTH ]
  264.                 LL-GLOBAL? 0=
  265.                 IF      LLAB-INIT               \ IN CASE LABELS USED
  266.                 THEN    ;
  267.  
  268. ONLY FORTH ALSO META ALSO DEFINITIONS
  269.  
  270. : SIZE-SET      ( --- )
  271.                 SEG-S @ 0= ?EXIT                \ leave if not saving sizes
  272.                 SEG-S @ DUP>R 0 @L              \ If non-zero then
  273.                 IF      HERE-T R@ 0 @L -        \ calculate actual length
  274.                         R@ DUP 0 @L !L          \ fill in CODE length WORD
  275.                         DP-X @                  \ length of list
  276.                         R@ DUP 0 @L 2+ !L       \ fill in LIST length WORD
  277.                         HERE-X PARAGRAPH-X + DPSEG-X ! DP-X OFF
  278.                                                 \ Round up LIST segment
  279.                 THEN    HERE-T R> 0 !L ;
  280.  
  281. : LABEL         ( | NAME -- )
  282.                 @> RUN =: ARUNSAVE
  283.                 0 ['] DROP A;!
  284.                 ['] RUN-A; IS RUN
  285.                 ASSEMBLER DEFINITIONS
  286.                 ?CLEAR-LABS
  287.                 >IN @ >R HERE-T CONSTANT
  288.                 LABELS @
  289.                 IF      R> >IN !
  290.                         BL WORD DUP C@ 5 + ?LINE
  291.                         HERE-T H.
  292.                         COUNT TYPE TAB
  293.                         ?NEWPAGE
  294.                 ELSE    R>DROP
  295.                 THEN    !CSP  ;
  296.  
  297. : XLABEL        ( | NAME -- )
  298.                 @> RUN =: ARUNSAVE
  299.                 0 ['] DROP A;!
  300.                 ['] RUN-A; IS RUN
  301.                 ASSEMBLER DEFINITIONS
  302.                 ?CLEAR-LABS
  303.                 >IN @ >R HERE-X >XREL CONSTANT
  304.                 LABELS @
  305.                 IF      R> >IN !
  306.                         BL WORD DUP C@ 5 + ?LINE
  307.                         HERE-T H.
  308.                         COUNT TYPE TAB
  309.                         ?NEWPAGE
  310.                 ELSE    R>DROP  THEN !CSP ;
  311.  
  312. : MAKE-CODE     ( PFA -- ) @ ,-X   ;                    \ Absolute address
  313. : MAKE-CODE-REL ( PFA -- ) @ HERE-T 2+ - ,-T   ;        \ Relative offset
  314.  
  315. : IN-TARGET     ( -- )          ONLY TARGET DEFINITIONS    ;
  316. : IN-TRANSITION ( -- )          ONLY FORWARD ALSO TARGET DEFINITIONS
  317.                                 ALSO TRANSITION    ;
  318. : IN-META       ( -- )          ONLY FORTH ALSO META DEFINITIONS ALSO  ;
  319. : IN-FORWARD    ( -- )          FORWARD DEFINITIONS    ;
  320. : LINK-BACKWARDS     ( PFA -- ) HERE-X >XREL OVER @ ,-X   SWAP !   ;
  321. : LINK-BACKWARDS-REL ( PFA -- ) HERE-T OVER @ ,-T   SWAP !   ;
  322. : RESOLVED?     ( pfa -- f )    2+ @   ;
  323.  
  324. : FORWARD-CODE  ( pfa -- )      DUP RESOLVED?
  325.                                 IF      MAKE-CODE
  326.                                 ELSE    LINK-BACKWARDS  THEN ;
  327.  
  328. : FORWARD-CODE-REL ( pfa -- )   DUP RESOLVED?
  329.                                 IF      MAKE-CODE-REL
  330.                                 ELSE    LINK-BACKWARDS-REL  THEN ;
  331.  
  332. : FORWARD:      ( -- )
  333.                 SWITCH   FORWARD DEFINITIONS
  334.                 CREATE SWITCH  0 , 0 , DOES>   FORWARD-CODE   ;
  335.  
  336. : FORWARD_REL:  ( -- )
  337.                 SWITCH   FORWARD DEFINITIONS
  338.                 CREATE SWITCH  0 , 0 , DOES>   FORWARD-CODE-REL ;
  339.  
  340. VARIABLE LAST-T
  341. VARIABLE CONTEXT-T
  342. VARIABLE CURRENT-T
  343.  
  344. VARIABLE WIDTH-T        31 WIDTH-T !
  345. VARIABLE WIDTH-SAVE     31 WIDTH-SAVE !
  346.  
  347. \ Use the normal HWORDS+ and HWORDS- to enable and disable the BEHEAD
  348. \ mechanism.  Use HEADERLESS and HEADERS as you would in regular Forth.
  349. \ BEHEAD while available is not needed in the meta compiler.
  350.  
  351. : HEADERLESS    ( --- )         \ disable generation of headers starting here
  352.                 beheadable WIDTH-T @ and
  353.                 if      WIDTH-T @ WIDTH-SAVE !
  354.                         WIDTH-T OFF
  355.                 then    ;
  356.  
  357. : HEADERS       ( --- )         \ re-enable the generation of headers here
  358.                 beheadable
  359.                 if      WIDTH-SAVE @ WIDTH-T !
  360.                 then    ;
  361.  
  362. : BEHEAD        ( --- ) ;       \ does NOTHING in the meta compiler
  363.  
  364. : HASH          ( str-addr voc-addr -- thread )
  365.                 SWAP
  366.                 DUP C@ SWAP 1+ DUP C@ 2* SWAP 1+ C@ + 2* +
  367.                 #TTHREADS 1- AND 2* +   ;
  368.  
  369. : HEADER        ( -- )
  370.                 BL WORD C@ 1+ WIDTH-T @ MIN   ?DUP
  371.         IF      ( HERE-Y 2- )   ( for ylink at end)
  372.                 ALIGN
  373.                 HERE-Y 2- @-Y CNHASH HERE-T CNHASH <> IF
  374.                 HERE-Y HERE-T CNHASH !-Y THEN  ( >NAME hash entry )
  375.                 LOADLINE @ ,-Y
  376.                 HERE CURRENT-T @ HASH DUP @-T ,-Y ( link )
  377.                 HERE-Y 2- SWAP !-T      ( point voc thread to link field )
  378.                 HERE-Y HERE ROT S,-Y   ALIGN   DUP LAST-T !
  379.                 128 SWAP CSET-Y   128 HERE-Y 1- CSET-Y
  380.                 HERE-T ,-Y              ( cfa ptr )
  381.                 HERE-Y HERE-T CNHASH 2+ !-Y     ( stopper >NAME hash entry )
  382.         THEN    ;
  383.  
  384. : TARGET-CREATE ( -- )
  385.                 >IN @ HEADER DUP >IN !
  386.                 LABELS @
  387.                 IF      BL WORD DUP C@ 5 + ?LINE
  388.                         HERE-T H.
  389.                         COUNT TYPE TAB ?NEWPAGE
  390.                 THEN    >IN !
  391.                 IN-TARGET CREATE IN-META  HERE-T , TRUE ,
  392.                 SIZE-SET
  393.                 DOES>   MAKE-CODE   ;
  394.  
  395. : RECREATE      ( -- )  >IN @   TARGET-CREATE   >IN !   ;
  396.  
  397.  
  398. FORTH DEFINITIONS
  399.  
  400. : CODE          ( NAME --- )
  401.                 @> RUN =: ARUNSAVE
  402.                 0 ['] DROP A;!
  403.                 ['] RUN-A; IS RUN
  404.                 TARGET-CREATE ASSEMBLER ?CLEAR-LABS !CSP  ;
  405.  
  406. : INLINE        ( --- )
  407.                 @> RUN =: ARUNSAVE
  408.                 0 ['] DROP A;!
  409.                 ['] RUN-A; IS RUN
  410.                 ASSEMBLER ?CLEAR-LABS !CSP HERE-T ,-X ;
  411.  
  412.  
  413. ASSEMBLER ALSO DEFINITIONS
  414.  
  415. : END-CODE      [ FORTH ]
  416.                 ll-global? 0=
  417.                 if      ll-errs?        \ check for local label errors
  418.                 then
  419.                 ARUNSAVE IS RUN
  420.                 A; IN-META ?CSP  ;
  421.  
  422. : END-INLINE    [ FORTH ]
  423.                 ll-global? 0=
  424.                 if      ll-errs?        \ check for local label errors
  425.                 then
  426.                 ARUNSAVE IS RUN
  427.                 A; IN-META ?CSP  ;
  428.  
  429. : C;            [ FORTH ]
  430.                 ll-global? 0=
  431.                 if      ll-errs?        \ check for local label errors
  432.                 then
  433.                 ARUNSAVE IS RUN
  434.                 A; IN-META ?CSP  ;
  435.  
  436. META IN-META
  437.  
  438. : 'T            ( -- cfa )
  439.                 CONTEXT @   TARGET DEFINED   ROT CONTEXT !
  440.                 0= ?MISSING   ;
  441.  
  442. : [TARGET]      ( -- )          'T X, ;   IMMEDIATE
  443.  
  444. : 'F            ( -- cfa )
  445.                 CONTEXT @   FORWARD DEFINED   ROT CONTEXT !
  446.                 0= ?MISSING   ;
  447.  
  448. : [FORWARD]     ( -- )  'F X, ;   IMMEDIATE
  449.  
  450. : T:            ( -- )
  451.                 SWITCH  TRANSITION DEFINITIONS
  452.                 CREATE  XHERE PARAGRAPH + DUP XDPSEG ! XSEG @ - , XDP OFF
  453.                 SWITCH   ]
  454.                 DOES>   @ +XSEG >R 0 >R ;
  455.  
  456. : T;            ( -- )
  457.                 SWITCH   TRANSITION DEFINITIONS   [COMPILE] ;    SWITCH   ;
  458.                 IMMEDIATE
  459.  
  460. : DIGIT?        ( CHAR -- F )   BASE @ DIGIT NIP   ;
  461.  
  462. : PUNCT?        ( CHAR -- F )
  463.                 '.' OVER = SWAP   '-' OVER = SWAP
  464.                 '/' OVER = SWAP   DROP OR OR ;
  465.  
  466. : NUMERIC?      ( ADDR LEN -- F )
  467.                 BASE @ >R
  468.                 OVER C@ '$' =
  469.                 IF      1- SWAP 1+ SWAP HEX
  470.                 THEN    DUP 1 =
  471.                 IF      DROP C@ DIGIT?
  472.                 ELSE    1 -ROT   0 ?DO   DUP C@   DUP DIGIT? SWAP PUNCT? OR
  473.                         ROT AND SWAP 1+   LOOP   DROP
  474.                 THEN    R> BASE ! ;
  475.  
  476. T: (    [COMPILE] (     T;
  477. T: (    [COMPILE] (     T;
  478. T: \    [COMPILE] \     T;
  479.  
  480. : STRING,-T     ( -- )
  481.                 '"' PARSE  DUP C,-T  S,-T  ALIGN  ;
  482.  
  483. : STRING,-X     ( -- )
  484.                 '"' PARSE  DUP C,-X  S,-X  ALIGN-X ;
  485.  
  486.                 FORWARD: <(.")>
  487. T: ."           [FORWARD]  <(.")>  STRING,-X   T;
  488.  
  489.                 FORWARD: <(")>
  490. T: "            [FORWARD] <(")>    HERE-T ,-X STRING,-T   T;
  491.  
  492.                 FORWARD: <(ABORT")>
  493. T: ABORT"       [FORWARD] <(ABORT")> STRING,-X   T;
  494.  
  495.                 FORWARD_REL: <VARIABLE>
  496. : CREATE        RECREATE
  497.                 232 C,-T
  498.                 [FORWARD] <VARIABLE>   HERE-T CONSTANT   ;
  499.  
  500. : VARIABLE      ( | name -- ) CREATE   0 ,-T   ;
  501.  
  502.                 FORWARD_REL: <DEFER>
  503. : DEFER         ( -- )
  504.                 TARGET-CREATE
  505.                 232 C,-T                        \ CALL instruction
  506.                 [FORWARD] <DEFER>   0 ,-T   ;
  507.  
  508. FORTH
  509.  
  510. VARIABLE #USER-T
  511.  
  512. META ALSO USER DEFINITIONS
  513.  
  514. : ALLOT         ( n -- )
  515.                 #USER-T +!   ;
  516.  
  517.                 FORWARD_REL: <USER-VARIABLE>
  518. : VARIABLE      ( -- )
  519.                 SWITCH   RECREATE
  520.                 232 C,-T
  521.                 [FORWARD] <USER-VARIABLE>   #USER-T @
  522.                 DUP ,-T   2 ALLOT   META DEFINITIONS   CONSTANT   SWITCH   ;
  523.  
  524.                 FORWARD_REL: <USER-DEFER>
  525. : DEFER         ( -- )
  526.                 SWITCH   TARGET-CREATE
  527.                 232 C,-T
  528.                 [FORWARD] <USER-DEFER>   SWITCH
  529.                 #USER-T @ ,-T   2 ALLOT   ;
  530.  
  531. ONLY FORTH ALSO META ALSO DEFINITIONS
  532.  
  533. FORTH VARIABLE VOC-LINK-T META
  534.  
  535.                 FORWARD_REL: <VOCABULARY>
  536. : VOCABULARY    ( -- )
  537.                 RECREATE
  538.                 232 C,-T                \ CALL instruction to DOVOC
  539.                 [FORWARD] <VOCABULARY>
  540.                 HERE-T   #TTHREADS 0 DO  0 ,-T  LOOP
  541.                 HERE-T VOC-LINK-T @ ,-T   VOC-LINK-T !
  542.                 CONSTANT DOES> @ CONTEXT-T !   ;
  543.  
  544. : IMMEDIATE     ( -- )
  545.                 WIDTH-T @
  546.                 IF ( Headers present? )
  547.                 64 ( Precedence Bit )   LAST-T @   CSET-Y   THEN   ;
  548.  
  549. FORWARD: <(;USES)>
  550.  
  551. FORTH
  552.  
  553. VARIABLE STATE-T
  554.  
  555. META
  556.  
  557. T: ;USES        ( -- )
  558.                 [FORWARD] <(;USES)>   IN-META ASSEMBLER
  559.                 !CSP   STATE-T OFF   T;
  560.  
  561. T: [COMPILE]    'T EXECUTE    T;
  562.  
  563.                 FORWARD: <(IS)>
  564. T: IS           [FORWARD] <(IS)>    T;
  565. :  IS           'T  ( CR HERE COUNT TYPE TAB OVER H. )
  566.                 >BODY @ >BODY-T !-T ;
  567.  
  568. T: ALIGN   T;
  569.  
  570. T: EVEN    T;
  571.  
  572. : .SYMBOLS      ( -- )
  573.                 TARGET   CONTEXT @ HERE #TTHREADS 2* CMOVE  CR
  574.                 BEGIN   HERE 4 LARGEST  DUP
  575.                 WHILE   DUP L>NAME  DUP Y@ 31 AND 2+ ?LINE
  576.                         ."  /  "  DUP .ID
  577.                         NAME> >BODY @ U.
  578.                         Y@ SWAP !
  579.                         KEY? IF   EXIT   THEN
  580.                 REPEAT  2DROP   IN-META   ;
  581.  
  582. : .UNRESOLVED   ( -- )
  583.                 UNRESOLVED OFF
  584.                 FORWARD CONTEXT @ HERE #THREADS 2* CMOVE
  585.                 BEGIN   HERE #THREADS LARGEST   DUP
  586.                 WHILE   ?CR DUP L>NAME NAME> >BODY
  587.                         RESOLVED? 0=
  588.                         IF      >ATTRIB4 DUP L>NAME .ID >NORM SPACE
  589.                                 UNRESOLVED ON
  590.                         THEN
  591.                         Y@  SWAP !
  592.                 REPEAT  2DROP .UNRESOLVEPAUSE IN-META ;
  593.  
  594. : FIND-UNRESOLVED ( -- cfa f )  'F    DUP  >BODY RESOLVED?     ;
  595.  
  596. DECIMAL
  597.  
  598. : RESOLVE       ( taddr cfa -- )        \ resolve for CODE space
  599.                 >BODY   2DUP   TRUE OVER 2+ !   @
  600.                 BEGIN   DUP
  601.                 WHILE   2DUP @-T   -ROT SWAP
  602.                         DUP 1-  C@-T 232 =            \ IF PRECEEDED BY CALL
  603.                         IF      DUP 2+ ROT SWAP - SWAP \ SWITCH TO RELATIVE
  604.                         THEN    !-T
  605.                 REPEAT  2DROP  ! ;
  606.  
  607. : RESOLVES      ( taddr -- )
  608.                 FIND-UNRESOLVED
  609.                 IF      CR >NAME .ID ." Already Resolved" DROP
  610.                 ELSE    RESOLVE   THEN   ;
  611.  
  612. : :RESOLVE      ( taddr cfa -- )        \ resolve for LIST space
  613.                 >BODY   2DUP   TRUE OVER 2+ !   @
  614.                 BEGIN   DUP
  615.                 WHILE   2DUP @-X   -ROT SWAP !-X
  616.                 REPEAT  2DROP  ! ;
  617.  
  618. : :RESOLVES     ( taddr -- )
  619.                 FIND-UNRESOLVED
  620.                 IF      CR >NAME .ID ." Already Resolved" DROP
  621.                 ELSE    :RESOLVE   THEN   ;
  622.  
  623. : H:    [COMPILE] :   ;
  624.  
  625. H: '     'T >BODY @   ;
  626. H: ,    ,-T ;
  627. H: C,  C,-T ;
  628. H: X,   ,-X ;
  629. H: XC, C,-X ;
  630.  
  631. H: HERE         HERE-T ;
  632. H: XHERE        ( HERE-X ) TRUE ABORT" Used HERE-X" ;
  633. H: ALLOT        ALLOT-T   ;
  634. H: DEFINITIONS  DEFINITIONS   CONTEXT-T @ CURRENT-T !    ;
  635.  
  636. ONLY FORTH DEFINITIONS ALSO
  637.  
  638. .( Meta Compiler Loaded )
  639.  
  640. CR .ELAPSED CR
  641.  
  642. FLOAD KERNEL1.SEQ
  643. FLOAD VIDEO.SEQ
  644. FLOAD KERNEL2.SEQ
  645. FLOAD VIDEO2.SEQ
  646. FLOAD KERNEL3.SEQ
  647. FLOAD EQUCOLON.SEQ
  648. FLOAD SAVEREST.SEQ
  649. FLOAD HANDLES.SEQ
  650. FLOAD SEQREAD.SEQ
  651. FLOAD FPATH.SEQ
  652. FLOAD DEFAULT.SEQ
  653. FLOAD KERNEL4.SEQ
  654.  
  655. ALSO META
  656.  
  657. SIZE-SAVE       \ Write the 64k image of CFA sizes to KERNEL.SIZ
  658.  
  659. PREVIOUS
  660.  
  661. CAPS ON
  662.  8 TABSIZE !    \ RESTORE TABS
  663. 70 RMARGIN !    \ RESTORE RIGHT MARGIN
  664. ?PAGE           \ NEW PAGE
  665. PRINTING OFF    \ NO PRINTING ANY MORE
  666. 0 24 AT           \ Go back there.
  667. CR CR
  668.