home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / opt80.seq < prev    next >
Text File  |  1990-05-17  |  13KB  |  355 lines
  1. \ OPT80.SEQ     Library Optimizers for Target Compiler
  2.  
  3. ONLY FORTH ALSO COMPILER ALSO DEFINITIONS TARGET ALSO
  4.  
  5. >FORTH
  6.  
  7. FORTH
  8.  
  9. : TVER80 ."  8080 Version 0.75 " ;
  10. ' TVER80 IS TVERSION
  11.  
  12. ' NOOP IS DATA-SEG-FIX          \ not a segmented machine
  13.  
  14. WARNING OFF                     \ NO REDEFINITION WARNING IN LIBRARY
  15. FORTH                           \ we want a Forth NOT a target variable
  16.  
  17. create cpm.ext ," CPM" 0 ,      \ define image file extension for 8080
  18.  
  19. cpm.ext count image.ext place   \ move into compilers .EXT array
  20.  
  21. \ ***************************************************************************
  22. \ New function for END-CODE, needs to not use REVEAL
  23.  
  24. ASM80 also forth also
  25.  
  26. : %SET_ENTRY    ( -- )          \ mark HERE-T as the cold entry point
  27.                 here-t cold_start !-t ;         \ Absolute addressing
  28.  
  29. ' %SET_ENTRY IS SET_COLD_ENTRY
  30.  
  31. FORTH
  32.  
  33. DEFER DO_RET
  34.  
  35. : CEND-CODE     ( -- )
  36.                 ll-global? 0=
  37.                 if      ll-errs?        \ check for local label errors
  38.                 then
  39.                 ARUNSAVE IS RUN
  40.                 PREVIOUS A; ;
  41.  
  42. previous previous target
  43.  
  44. : %END-MACRO    ( -- )          \ complete assembly of a MACRO
  45.                 ?reopt
  46.                 [ASM80]
  47.                 compile a;                      \ make sure ASM80 is done
  48.                 compile cend-code               \ pop ASM80 vocabulary
  49.                 [compile] FOR; ;                \ complete colon def
  50.  
  51. ' %END-MACRO IS END-MACRO       \ install in END-MACRO
  52.  
  53. : %END-LCODE    ( -- )          \ complete assembly of a LCODE
  54.                 ?reopt
  55.                 [ASM80]
  56.                 compile a;                      \ make sure ASM80 is done
  57.                 compile cend-code               \ pop ASM80 vocabulary
  58.                 [compile] FOR; ;                \ complete colon def
  59.  
  60. ' %END-LCODE IS END-LCODE       \ install in END-LCODE
  61.  
  62. : %END-L:       ( -- )          \ complete a library CALL definition
  63.                 [ASM80]
  64.                 compile setassem
  65.                 compile DO_RET
  66.                 compile a;                      \ make sure ASM80 is done
  67.                 compile cend-code               \ pop ASM80 vocabulary
  68.                 compile unnest ;
  69.  
  70. ' %END-L: IS END-L:
  71.  
  72. : %END-LM:      ( -- )          \ complete a library MACRO : definition
  73.                 [ASM80]
  74.                 compile setassem
  75.                 compile cend-code
  76.                 compile unnest ;
  77.  
  78. ' %END-LM: IS END-LM:
  79.  
  80. : %END-T:       ( -- )          \ complete a target CALL definition
  81.                 [ASM80]
  82.                 setassem                \ do ASM80 setup
  83.                 DO_RET a;               \ terminate with a RET instruction
  84.                 fend-code ;             \ do ASM80 finishup
  85.  
  86. ' %END-T: IS END-T:
  87.  
  88. : %COMP_CALL    ( a1 -- )                       \ a1 = CFA of symbol
  89.                 dup     >resaddr @ dup -1 <>    \ if resolved already
  90.                 if      ,-T                     \ resolve this call
  91.                         >count incr             \ bump use count
  92.                                         \ ELSE, add it to the chain of
  93.                 else    drop                    \ discard the "-1"
  94.                                                 \ references to be resolved.
  95.                         dup >chain @ ,-T        \ link chain @ to here
  96.                         here-t 2- over >chain ! \ link here into chain
  97.                         >res                    \ add to resolution stack
  98.                 then    ;
  99.  
  100. ' %COMP_CALL IS COMP_CALL
  101.  
  102. : %RESOLVE_ONE  ( a1 -- )               \ resolve a forward reference
  103.                 here-t swap !-T ;       \ for absolute addresses
  104.  
  105. ' %RESOLVE_ONE IS RESOLVE_1             \ link into compiler
  106.  
  107. ' DROP IS COMP_JMP_IMM
  108.  
  109. : %SUB_RET      ( -- )
  110.                 -2 ALLOT-T ;
  111.  
  112. ' SUB_RET IS SUB_RET
  113.  
  114. : %TCODE-START  ( -- )
  115.                 setassem                \ initialize the ASM80
  116.                 here-t 2+ ,-t           \ start code words pointing to body
  117.                 [assembler]
  118.                 llab-init ;             \ clear all labels
  119.  
  120. ' %TCODE-START IS TCODE-START
  121.  
  122. : %MACRO-START  ( -- )
  123.                 compile setassem        \ initialize the ASM80
  124.                 ASM80 ;                 \ and select ASM80 vocabulary now!
  125.  
  126. ' %MACRO-START IS MACRO-START
  127.  
  128. : %LCODE-START  ( -- )
  129.                 compile %tcode-start   \ initialize the code word CFA
  130.                 ASM80 ;                 \ and select ASM80 vocabulary now!
  131.  
  132. ' %LCODE-START IS LCODE-START
  133.  
  134.  
  135. \ ***************************************************************************
  136.  
  137. ONLY FORTH ALSO COMPILER ALSO HTARGET ALSO TARGET ALSO DEFINITIONS
  138. ASM80 ALSO
  139.  
  140. >LIBRARY                        \ Select the Library versions of
  141.                                 \ defining words.
  142.  
  143.  
  144. \ ***************************************************************************
  145. \ Use great caution when changing any of the following constants, they
  146. \ point into specific places in the initialization code that follows.
  147.  
  148. $100 CONSTANT ORIGIN
  149. $108 CONSTANT DPUSH
  150. $109 CONSTANT HPUSH
  151. $10A CONSTANT >NEXT
  152. $110 CONSTANT >NEXT1
  153. $115 CONSTANT NEST
  154. $126 CONSTANT DODOES
  155. $137 CONSTANT DOCREATE
  156. $13C CONSTANT DOCONSTANT
  157. $145 CONSTANT DODEFER
  158. $14E CONSTANT RP0
  159. $150 CONSTANT RP               \ Not enough registers on an 8080
  160. $152 CONSTANT SP0
  161. $154 CONSTANT VOC-INIT
  162.  
  163. \ ***************************************************************************
  164. \ Use great caution when changing any of this code, the constants above
  165. \ point into the following code to specific routines.
  166.  
  167. MACRO IMAGE-INIT ( -- )         \ Target compiler runtime initialization
  168.                 [assembler]
  169.                 llab-init
  170.                 [ASM80]
  171. \ LABEL ORIGIN
  172.         NOP  0 $ JMP    ( Low Level COLD Entry point )
  173.         NOP   -1 JMP    ( Low Level WARM Entry point )
  174.  
  175. \ LABEL DPUSH
  176.         D PUSH
  177.  
  178. \ LABEL HPUSH
  179.         H PUSH
  180.  
  181. \ LABEL >NEXT
  182.         IP LDAX   IP INX    A L MOV   IP LDAX   IP INX   A H MOV
  183.  
  184. \ LABEL >NEXT1
  185.         M E MOV   H INX   M D MOV   XCHG   PCHL
  186.  
  187. \ LABEL NEST
  188.         RP LHLD  H DCX  H DCX  RP SHLD   C M MOV  H INX  B M MOV
  189.         D INX  E C MOV  D B MOV  >NEXT JMP ( predecrement RP (mjm)
  190.  
  191. \ LABEL DODOES
  192.         RP LHLD  H DCX  H DCX  RP SHLD   C M MOV  H INX  B M MOV
  193.         B POP   D INX   D PUSH   >NEXT JMP
  194.  
  195. \ LABEL DOCREATE
  196.         D INX  D PUSH   >NEXT JMP
  197.  
  198. \ LABEL DOCONSTANT
  199.         D INX  XCHG  M E MOV  H INX  M D MOV  D PUSH  >NEXT JMP
  200.  
  201. \ LABEL DODEFER   ( -- )
  202.         D INX  XCHG M E MOV  H INX  M D MOV  XCHG  >NEXT1 JMP
  203.  
  204. \ LABEL RP0             A special location to hold RP0
  205.         0 ,-T
  206.  
  207. \ LABEL RP              A special location to hold RP
  208.         0 ,-T
  209.  
  210. \ LABEL SP0             A special location to hold SP0
  211.         0 ,-T
  212.  
  213. \ LABEL VOC-INIT        A special location to hold VOC-INIT
  214.         0 ,-T
  215.  
  216. \ COLD ENTRY POINT
  217. 0 $:
  218.       $C000 H LXI
  219.           RP SHLD                                       \ RP at $C000
  220.            H PUSH
  221.         RP0 D LXI                                       \ RP0 same as RP
  222.             H POP $100 NEGATE D LXI D DAD H PUSH
  223.         SP0 D LXI                                       \ SP0 = RP0 - $100
  224.       $0000 H LXI                                       \ entry point
  225.                 here-t 2- =: cold_start                 \ set patch pointer
  226.        >NEXT1 JMP
  227.  
  228. END-MACRO       \ ***** End of IMAGE-INIT *****
  229.  
  230. \ ***************************************************************************
  231.  
  232. FORTH >FORTH
  233.  
  234. : %START-T:     ( -- )
  235.                 F['] NEST >RESADDR @ ,-T ;
  236.  
  237. ' %START-T: IS START-T:
  238.  
  239. FORTH VARIABLE TLAST
  240.  
  241. : %HEADER       ( A1 -- )       \ a1 = addr of counted name string
  242.                 [FORTH]
  243.                                         \ make a chain of headers
  244.                 HERE-T F['] VOC-INIT >RESADDR @ DUP @-T ,-T !-T
  245.                 HERE-T 2+ TLAST !       \ mark in TLAST for IMMEDIATE
  246.                 dup c@ 1+ s,-t  ;       \ compile in header
  247.  
  248. ' %HEADER IS COMP_HEADER                \ link into compiler
  249.  
  250. \ ***************************************************************************
  251. \ Re-define VARIABLE and CONSTANT to work with this indirect threaded system
  252.  
  253. : %VAR          ( a1 -- )
  254.                 F['] DOCREATE >resaddr @        \ addr of "docreate"
  255.                 here-t 2- !-t                   \ set CFA to DOCREATE
  256.                 here-t 2- swap >resaddr !       \ resolve to CFA
  257.                 0 ,-t   ;                       \ fill body with zero
  258.  
  259. : VARIABLE      ( | <name> -- )
  260.                 fhere >r
  261.                 (L:)                            \ make header
  262.                 compile (lit) r> x,
  263.                 compile %var
  264.                 compile unnest
  265.                 does>   [forth]
  266.                         body>
  267.                         dup >resaddr @ -1 =
  268.                         if  dup >execute execute
  269.                         then
  270.                         dup >count incr         \ bump usage
  271.                             >resaddr @ 2+ ;     \ return address of var body
  272.  
  273. : %CON          ( n1 a1 -- )
  274.                 F['] DOCONSTANT >resaddr @      \ addr of "doconstant"
  275.                 here-t 2- !-t                   \ set CFA to DOCONSTANT
  276.                 here-t 2- swap >resaddr !       \ resolve to CFA
  277.                 ,-t   ;                         \ fill body with value
  278.  
  279. : CONSTANT      ( n1 | <name> -- )
  280.                 fhere >r
  281.                 (L:)                            \ make header
  282.                 compile (lit) x,
  283.                 compile (lit) r> x,
  284.                 compile %CON
  285.                 compile unnest
  286.                 does>   [forth]
  287.                         body>
  288.                         dup >resaddr @ -1 =
  289.                         if  dup >execute execute
  290.                         then
  291.                         dup >count incr         \ bump usage
  292.                             >resaddr @ 2+ @-t ; \ return constant's value
  293.  
  294. : %DEF          ( a1 -- )
  295.                 F['] DODEFER >resaddr @         \ addr of "dodefer"
  296.                 here-t 2- !-t                   \ set CFA to DODEFER
  297.                 here-t 2- swap >resaddr !       \ resolve to body
  298.                 0 ,-t   ;                       \ fill body with NULL
  299.  
  300. : DEFER         ( <name> -- )
  301.                 fhere >r
  302.                 (L:)                            \ make header
  303.                 compile (lit) r> x,
  304.                 compile %DEF
  305.                 compile unnest
  306.                 does>   drop
  307.                 0 " Can't use target DEFERed words in interpret mode!"
  308.                 "errmsg abort ;
  309.  
  310. \ ***************************************************************************
  311. \ Assure that the name following INCLUDEWORD is included in the target
  312. \ wheather it is used of not. This is needed when building a full forth
  313. \ kernel, to make sure all functions are included even if they aren't
  314. \ referenced by COLD.
  315.  
  316. : INCLUDEWORD   ( | <name> -- )                 \ include function <name>
  317.                 [forth]                         \ FORTH needed for IF & THEN
  318.                 '       dup >resaddr @ -1 =     \ if NOT resolved
  319.                 if      dup >res                \ add to resolution stack
  320.                         do_resolve              \ and resolve it NOW
  321.                 then    drop ;
  322.  
  323. FORTH DEFINITIONS
  324.  
  325. DEFER DEF-INIT                  \ default target initialization
  326. DEFER NO-INIT                   \ default NO initialization
  327.  
  328. : TARGET-INIT   ( -- )          \ initialize the terget compiler
  329.                 ?LIB ABORT" Cant use TARGET-INIT in a library routine"
  330.                 ONLY FORTH ALSO COMPILER ALSO
  331.                 TARGET ALSO DEFINITIONS ASM80 ALSO
  332.                 tseg_init       \ Initialize the target compile buffer
  333.                 >target         \ select target defining words
  334.                 target          \ Select the target vocabulary
  335.                 F['] IMAGE-INIT                 \ address of init routine
  336.                 DUP >COUNT INCR                 \ mark it used and
  337.                         >EXECUTE EXECUTE        \ compile it
  338.                 ?DEFINIT
  339.                 IF      DEF-INIT
  340.                 ELSE    NO-INIT
  341.                 THEN    ; IMMEDIATE
  342.  
  343. ' TARGET-INIT IS TARGET-INITIALIZE
  344.  
  345. ASM80 DEFINITIONS FORTH     >LIBRARY
  346.  
  347. \ ***************************************************************************
  348. \                           OPTIMIZERS !!
  349. \ ***************************************************************************
  350.  
  351. FORTH   >FORTH
  352.  
  353. >LIBRARY
  354.  
  355.