File:  [gforth] / gforth / cross.fs
Revision 1.52: download - view: text, annotated - select for diffs
Sun Aug 31 19:31:28 1997 UTC (22 years, 2 months ago) by jwilke
Branches: MAIN
CVS tags: HEAD
changes from gforth-ec:
updated cross (side-effect: no more warnings :-)
some changed other forth-files
['] can not do forward references any more

    1: \ CROSS.FS     The Cross-Compiler                      06oct92py
    2: \ Idea and implementation: Bernd Paysan (py)
    3: 
    4: \ Copyright (C) 1995 Free Software Foundation, Inc.
    5: 
    6: \ This file is part of Gforth.
    7: 
    8: \ Gforth is free software; you can redistribute it and/or
    9: \ modify it under the terms of the GNU General Public License
   10: \ as published by the Free Software Foundation; either version 2
   11: \ of the License, or (at your option) any later version.
   12: 
   13: \ This program is distributed in the hope that it will be useful,
   14: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   15: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16: \ GNU General Public License for more details.
   17: 
   18: \ You should have received a copy of the GNU General Public License
   19: \ along with this program; if not, write to the Free Software
   20: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   21: 
   22: \ Log:
   23: \       changed in ; [ to state off           12may93jaw
   24: \       included place +place                 12may93jaw
   25: \       for a created word (variable, constant...)
   26: \       is now an alias in the target voabulary.
   27: \       this means it is no longer necessary to
   28: \       switch between vocabularies for variable
   29: \       initialization                        12may93jaw
   30: \       discovered error in DOES>
   31: \       replaced !does with (;code)           16may93jaw
   32: \       made complete redesign and
   33: \       introduced two vocs method
   34: \       to be asure that the right words
   35: \       are found                             08jun93jaw
   36: \       btw:  ! works not with 16 bit
   37: \             targets                         09jun93jaw
   38: \       added: 2user and value                11jun93jaw
   39: 
   40: \ 	needed? works better now!!!		01mar97jaw
   41: \	mach file is only loaded into target
   42: \	cell corrected
   43: \ 	romable extansions			27apr97-5jun97jaw
   44: 
   45: 
   46: hex     \ the defualt base for the cross-compiler is hex !!
   47: Warnings off
   48: 
   49: \ words that are generaly useful
   50: 
   51: : >wordlist ( vocabulary-xt -- wordlist-struct )
   52:   also execute get-order swap >r 1- set-order r> ;
   53: 
   54: : umax 2dup u< IF swap THEN drop ;
   55: : umin 2dup u> IF swap THEN drop ;
   56: 
   57: : string, ( c-addr u -- )
   58:     \ puts down string as cstring
   59:     dup c, here swap chars dup allot move ;
   60: 
   61: : SetValue ( n -- <name> )
   62: \G Same behaviour as "Value" when the <name> is not defined
   63: \G Same behaviour as "to" when <name> is defined
   64: \G SetValue searches in the current vocabulary
   65:  save-input bl word >r restore-input throw r> count
   66:  get-current search-wordlist
   67:  IF bl word drop >body ! ELSE Value THEN ;
   68: 
   69: : DefaultValue ( n -- <name> )
   70: \G Same behaviour as "Value" when the <name> is not defined
   71: \G SetValue searches in the current vocabulary
   72:  save-input bl word >r restore-input throw r> count
   73:  get-current search-wordlist
   74:  IF bl word drop drop drop ELSE Value THEN ;
   75: 
   76: hex
   77: 
   78: Vocabulary Cross
   79: Vocabulary Target
   80: Vocabulary Ghosts
   81: VOCABULARY Minimal
   82: only Forth also Target also also
   83: definitions Forth
   84: 
   85: : T  previous Cross also Target ; immediate
   86: : G  Ghosts ; immediate
   87: : H  previous Forth also Cross ; immediate
   88: 
   89: forth definitions
   90: 
   91: : T  previous Cross also Target ; immediate
   92: : G  Ghosts ; immediate
   93: 
   94: : >cross  also Cross definitions previous ;
   95: : >target also Target definitions previous ;
   96: : >minimal also Minimal definitions previous ;
   97: 
   98: H
   99: 
  100: >CROSS
  101: 
  102: \ 1 Constant Cross-Flag	\ to check whether assembler compiler plug-ins are
  103: 			\ for cross-compiling
  104: \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
  105: 
  106: : comment? ( c-addr u -- c-addr u )
  107:         2dup s" (" compare 0=
  108:         IF    postpone (
  109:         ELSE  2dup s" \" compare 0= IF postpone \ THEN
  110:         THEN ;
  111: 
  112: \ Begin CROSS COMPILER:
  113: 
  114: 
  115: 
  116: \ \ --------------------        Error Handling                  05aug97jaw
  117: 
  118: \ Flags
  119: 
  120: also forth definitions  \ these values may be predefined before
  121:                         \ the cross-compiler is loaded
  122: 
  123: false DefaultValue stack-warn   	 \ check on empty stack at any definition
  124: false DefaultValue create-forward-warn   \ warn on forward declaration of created words
  125: 
  126: [IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN]
  127: [IFUNDEF] DebugMaskCross  Variable DebugMaskCross  0 DebugMaskCross  ! [THEN]
  128: 
  129: previous >CROSS
  130: 
  131: : .sourcepos
  132:   cr sourcefilename type ." :"
  133:   base @ decimal sourceline# . base ! ;
  134: 
  135: : warnhead
  136: \G display error-message head
  137: \G perhaps with linenumber and filename
  138:   .sourcepos ." Warning: " ;
  139: 
  140: : empty? depth IF .sourcepos ." Stack not empty!"  THEN ;
  141: 
  142: stack-warn [IF]
  143: : defempty? empty? ;
  144: [ELSE]
  145: : defempty? ; immediate
  146: [THEN]
  147: 
  148: 
  149: \ \ GhostNames Ghosts                                  9may93jaw
  150: 
  151: \ second name source to search trough list
  152: 
  153: VARIABLE GhostNames
  154: 0 GhostNames !
  155: 
  156: : GhostName ( -- addr )
  157:     here GhostNames @ , GhostNames ! here 0 ,
  158:     bl word count
  159:     \ 2dup type space
  160:     string, \ !! cfalign ?
  161:     align ;
  162: 
  163: \ Ghost Builder                                        06oct92py
  164: 
  165: \ <T T> new version with temp variable                 10may93jaw
  166: 
  167: VARIABLE VocTemp
  168: 
  169: : <T  get-current VocTemp ! also Ghosts definitions ;
  170: : T>  previous VocTemp @ set-current ;
  171: 
  172: hex
  173: 4711 Constant <fwd>             4712 Constant <res>
  174: 4713 Constant <imm>             4714 Constant <do:>
  175: 
  176: \ iForth makes only immediate directly after create
  177: \ make atonce trick! ?
  178: 
  179: Variable atonce atonce off
  180: 
  181: : NoExec true ABORT" CROSS: Don't execute ghost" ;
  182: 
  183: : GhostHeader <fwd> , 0 , ['] NoExec , ;
  184: 
  185: : >magic ;		\ type of ghost
  186: : >link cell+ ;		\ pointer where ghost is in target, or if unresolved
  187: 			\ points to the where we have to resolve (linked-list)
  188: : >exec cell+ cell+ ;	\ execution symantics (while target compiling) of ghost
  189: : >end 3 cells + ;	\ room for additional tags
  190: 			\ for builder (create, variable...) words the
  191: 			\ execution symantics of words built are placed here
  192: 
  193: Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
  194: Variable last-ghost	\ last ghost that is created
  195: Variable last-header-ghost \ last ghost definitions with header
  196: 
  197: : Make-Ghost ( "name" -- ghost )
  198:   >in @ GhostName swap >in !
  199:   <T Create atonce @ IF immediate atonce off THEN
  200:   here tuck swap ! ghostheader T>
  201:   dup last-ghost !
  202:   DOES> dup executed-ghost ! >exec @ execute ;
  203: 
  204: \ ghost words                                          14oct92py
  205: \                                          changed:    10may93py/jaw
  206: 
  207: : gfind   ( string -- ghost true/1 / string false )
  208: \ searches for string in word-list ghosts
  209:   dup count [ ' ghosts >wordlist ] ALiteral search-wordlist
  210:   dup IF >r >body nip r>  THEN ;
  211: 
  212: : gdiscover ( xt -- ghost true | xt false )
  213:   GhostNames
  214:   BEGIN @ dup
  215:   WHILE 2dup
  216:         cell+ @ dup >magic @ <fwd> <>
  217:         >r >link @ = r> and
  218:         IF cell+ @ nip true EXIT THEN
  219:   REPEAT
  220:   drop false ;
  221: 
  222: VARIABLE Already
  223: 
  224: : ghost   ( "name" -- ghost )
  225:   Already off
  226:   >in @  bl word gfind   IF  Already on nip EXIT  THEN
  227:   drop  >in !  Make-Ghost ;
  228: 
  229: : >ghostname ( ghost -- adr len )
  230:   GhostNames
  231:   BEGIN @ dup
  232:   WHILE 2dup cell+ @ =
  233:   UNTIL nip 2 cells + count
  234:   ELSE  2drop true abort" CROSS: Ghostnames inconsistent"
  235:   THEN ;
  236: 
  237: ' >ghostname ALIAS @name
  238: 
  239: : forward? ( ghost -- flag )
  240:   >magic @ <fwd> = ;
  241: 
  242: \ Predefined ghosts                                    12dec92py
  243: 
  244: ghost 0=                                        drop
  245: ghost branch    ghost ?branch                   2drop
  246: ghost (do)      ghost (?do)                     2drop
  247: ghost (for)                                     drop
  248: ghost (loop)    ghost (+loop)                   2drop
  249: ghost (next)                                    drop
  250: ghost unloop    ghost ;S                        2drop
  251: ghost lit       ghost (compile) ghost !         2drop drop
  252: ghost (does>)   ghost noop                      2drop
  253: ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
  254: ghost '                                         drop
  255: ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
  256: ghost over      ghost =         ghost drop      2drop drop
  257: ghost - drop
  258: 
  259: \ \ Parameter for target systems                         06oct92py
  260: 
  261: \ we define it ans like...
  262: wordlist Constant target-environment
  263: 
  264: VARIABLE env-current \ save information of current dictionary to restore with environ>
  265: 
  266: : >ENVIRON get-current env-current ! target-environment set-current ;
  267: : ENVIRON> env-current @ set-current ; 
  268: 
  269: >TARGET
  270: 
  271: : environment?
  272:   target-environment search-wordlist 
  273:   IF execute true ELSE false THEN ;
  274: 
  275: : e? name T environment? H 0= ABORT" environment variable not defined!" ;
  276: 
  277: : has? name T environment? H IF ELSE false THEN ;
  278: 
  279: : $has? T environment? H IF ELSE false THEN ;
  280: 
  281: >ENVIRON
  282: true Value cross
  283: >TARGET
  284: 
  285: mach-file count included hex
  286: 
  287: >TARGET
  288: 
  289: [IFUNDEF] has-interpreter true Value has-interpreter [THEN]
  290: [IFUNDEF] itc true Value itc [THEN]
  291: [IFUNDEF] has-rom false Value has-rom [THEN]
  292: 
  293: >CROSS
  294: 
  295: \ \ Create additional parameters                         19jan95py
  296: 
  297: T
  298: NIL		   Constant TNIL
  299: cell               Constant tcell
  300: cell<<             Constant tcell<<
  301: cell>bit           Constant tcell>bit
  302: bits/byte          Constant tbits/byte
  303: float              Constant tfloat
  304: 1 bits/byte lshift Constant maxbyte
  305: H
  306: 
  307: \ Variables                                            06oct92py
  308: 
  309: Variable image
  310: Variable tlast    TNIL tlast !  \ Last name field
  311: Variable tlastcfa \ Last code field
  312: Variable tdoes    \ Resolve does> calls
  313: Variable bit$
  314: 
  315: \ statistics						10jun97jaw
  316: 
  317: Variable headers-named 0 headers-named !
  318: Variable user-vars 0 user-vars !
  319: 
  320: \ Memory initialisation                                05dec92py
  321: 
  322: [IFDEF] Memory \ Memory is a bigFORTH feature
  323:    also Memory
  324:    : initmem ( var len -- )
  325:      2dup swap handle! >r @ r> erase ;
  326:    toss
  327: [ELSE]
  328:    : initmem ( var len -- )
  329:      tuck allocate abort" CROSS: No memory for target"
  330:      ( len var adr ) dup rot !
  331:      ( len adr ) swap erase ;
  332: [THEN]
  333: 
  334: \ MakeKernal                                           12dec92py
  335: 
  336: : makekernel ( targetsize -- targetsize )
  337:   bit$  over 1- tcell>bit rshift 1+ initmem
  338:   image over initmem ;
  339: 
  340: >MINIMAL
  341: : makekernel makekernel ;
  342: 
  343: 
  344: >CROSS
  345: 
  346: \ memregion.fs
  347: 
  348: 
  349: Variable last-defined-region    \ pointer to last defined region
  350: Variable region-link            \ linked list with all regions
  351: Variable mirrored-link          \ linked list for mirrored regions
  352: 0 dup mirrored-link ! region-link !
  353: 
  354: 
  355: : >rdp 2 cells + ;
  356: : >rlen cell+ ;
  357: : >rstart ;
  358: 
  359: 
  360: : region ( addr len -- )                \G create a new region
  361:   \ check whether predefined region exists 
  362:   save-input bl word find >r >r restore-input throw r> r> 0= 
  363:   IF	\ make region
  364: 	drop
  365: 	save-input create restore-input throw
  366: 	here last-defined-region !
  367: 	over ( startaddr ) , ( length ) , ( dp ) ,
  368: 	region-link linked name string,
  369:   ELSE	\ store new parameters in region
  370:         bl word drop
  371: 	>body >r r@ last-defined-region !
  372: 	r@ cell+ ! dup r@ ! r> 2 cells + !
  373:   THEN ;
  374: 
  375: : borders ( region -- startaddr endaddr ) \G returns lower and upper region border
  376:   dup @ swap cell+ @ over + ;
  377: 
  378: : extent  ( region -- startaddr len )   \G returns the really used area
  379:   dup @ swap 2 cells + @ over - ;
  380: 
  381: : area ( region -- startaddr totallen ) \G returns the total area
  382:   dup @ swap cell+ @ ;
  383: 
  384: : mirrored                              \G mark a region as mirrored
  385:   mirrored-link
  386:   linked last-defined-region @ , ;
  387: 
  388: : .addr
  389:   base @ >r hex
  390:   tcell 2 u>
  391:   IF s>d <# # # # # '. hold # # # # #> type
  392:   ELSE s>d <# # # # # # #> type
  393:   THEN r> base ! ;
  394: 
  395: : .regions                      \G display region statistic
  396: 
  397:   \ we want to list the regions in the right order
  398:   \ so first collect all regions on stack
  399:   0 region-link @
  400:   BEGIN dup WHILE dup @ REPEAT drop
  401:   BEGIN dup
  402:   WHILE cr 3 cells - >r
  403: 	r@ 4 cells + count tuck type
  404:         12 swap - 0 max spaces space
  405: 	." Start: " r@ @ dup .addr space
  406: 	." End: " r@ 1 cells + @ + .addr space
  407: 	." DP: " r> 2 cells + @ .addr 
  408:   REPEAT drop
  409:   s" rom" $has? 0= ?EXIT
  410:   cr ." Mirrored:"
  411:   mirrored-link @
  412:   BEGIN dup
  413:   WHILE	space dup cell+ @ 4 cells + count type @
  414:   REPEAT drop cr
  415:   ;
  416: 
  417: \ -------- predefined regions
  418: 
  419: 0 0 region address-space
  420: \ total memory addressed and used by the target system
  421: 
  422: 0 0 region dictionary
  423: \ rom area for the compiler
  424: 
  425: has? rom 
  426: [IF]
  427: 0 0 region ram-dictionary mirrored
  428: \ ram area for the compiler
  429: [ELSE]
  430: ' dictionary ALIAS ram-dictionary
  431: [THEN]
  432: 
  433: 0 0 region return-stack
  434: 
  435: 0 0 region data-stack
  436: 
  437: 0 0 region tib-region
  438: 
  439: ' dictionary ALIAS rom-dictionary
  440: 
  441: 
  442: : setup-target ( -- )   \G initialize targets memory space
  443:   s" rom" $has?
  444:   IF  \ check for ram and rom...
  445:       address-space area nip
  446:       ram-dictionary area nip
  447:       rom-dictionary area nip
  448:       and and 0=
  449:       ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
  450:   THEN
  451:   address-space area nip
  452:   IF
  453:       address-space area
  454:   ELSE
  455:       dictionary area
  456:   THEN
  457:   dup 0=
  458:   ABORT" CROSS: define at least address-space or dictionary!!"
  459:   + makekernel drop ;
  460: 
  461: \ switched tdp for rom support				03jun97jaw
  462: 
  463: \ second value is here to store some maximal value for statistics
  464: \ tempdp is also embedded here but has nothing to do with rom support
  465: \ (needs switched dp)
  466: 
  467: variable tempdp	0 ,	\ temporary dp for resolving
  468: variable tempdp-save
  469: 
  470: 0 [IF]
  471: variable romdp 0 ,      \ Dictionary-Pointer for ramarea
  472: variable ramdp 0 ,      \ Dictionary-Pointer for romarea
  473: 
  474: \
  475: variable sramdp		\ start of ram-area for forth
  476: variable sromdp		\ start of rom-area for forth
  477: 
  478: [THEN]
  479: 
  480: 
  481: 0 value tdp
  482: variable fixed		\ flag: true: no automatic switching
  483: 			\	false: switching is done automatically
  484: 
  485: \ Switch-Policy:
  486: \
  487: \ a header is always compiled into rom
  488: \ after a created word (create and variable) compilation goes to ram
  489: \
  490: \ Be careful: If you want to make the data behind create into rom
  491: \ you have to put >rom before create!
  492: 
  493: variable constflag constflag off
  494: 
  495: : (switchram)
  496:   fixed @ ?EXIT has-rom 0= ?EXIT
  497:   ram-dictionary >rdp to tdp ;
  498: 
  499: : switchram
  500:   constflag @
  501:   IF constflag off ELSE (switchram) THEN ;
  502: 
  503: : switchrom
  504:   fixed @ ?EXIT rom-dictionary >rdp to tdp ;
  505: 
  506: : >tempdp ( addr -- ) 
  507:   tdp tempdp-save ! tempdp to tdp tdp ! ;
  508: : tempdp> ( -- )
  509:   tempdp-save @ to tdp ;
  510: 
  511: : >ram  fixed off (switchram) fixed on ;
  512: : >rom  fixed off switchrom fixed on ;
  513: : >auto fixed off switchrom ;
  514: 
  515: 
  516: 
  517: \ : romstart dup sromdp ! romdp ! ;
  518: \ : ramstart dup sramdp ! ramdp ! ;
  519: 
  520: \ default compilation goed to rom
  521: \ when romable support is off, only the rom switch is used (!!)
  522: >auto
  523: 
  524: : there  tdp @ ;
  525: 
  526: >TARGET
  527: 
  528: \ \ Target Memory Handling
  529: 
  530: \ Byte ordering and cell size                          06oct92py
  531: 
  532: : cell+         tcell + ;
  533: : cells         tcell<< lshift ;
  534: : chars         ;
  535: : char+		1 + ;
  536: : floats	tfloat * ;
  537:     
  538: >CROSS
  539: : cell/         tcell<< rshift ;
  540: >TARGET
  541: 20 CONSTANT bl
  542: \ TNIL Constant NIL
  543: 
  544: >CROSS
  545: 
  546: bigendian
  547: [IF]
  548:    : S!  ( n addr -- )  >r s>d r> tcell bounds swap 1-
  549:      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
  550:    : S@  ( addr -- n )  >r 0 0 r> tcell bounds
  551:      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
  552: [ELSE]
  553:    : S!  ( n addr -- )  >r s>d r> tcell bounds
  554:      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
  555:    : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
  556:      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
  557: [THEN]
  558: 
  559: >CROSS
  560: \ Bit string manipulation                               06oct92py
  561: \                                                       9may93jaw
  562: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
  563: : bits ( n -- n ) chars Bittable + c@ ;
  564: 
  565: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
  566: : +bit ( addr n -- )  >bit over c@ or swap c! ;
  567: : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
  568: : relon ( taddr -- )  bit$ @ swap cell/ +bit ;
  569: : reloff ( taddr -- )  bit$ @ swap cell/ -bit ;
  570: 
  571: \ Target memory access                                 06oct92py
  572: 
  573: : align+  ( taddr -- rest )
  574:     tcell tuck 1- and - [ tcell 1- ] Literal and ;
  575: : cfalign+  ( taddr -- rest )
  576:     \ see kernel.fs:cfaligned
  577:     /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
  578: 
  579: >TARGET
  580: : aligned ( taddr -- ta-addr )  dup align+ + ;
  581: \ assumes cell alignment granularity (as GNU C)
  582: 
  583: : cfaligned ( taddr1 -- taddr2 )
  584:     \ see kernel.fs
  585:     dup cfalign+ + ;
  586: 
  587: >CROSS
  588: : >image ( taddr -- absaddr )  image @ + ;
  589: >TARGET
  590: : @  ( taddr -- w )     >image S@ ;
  591: : !  ( w taddr -- )     >image S! ;
  592: : c@ ( taddr -- char )  >image c@ ;
  593: : c! ( char taddr -- )  >image c! ;
  594: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
  595: : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
  596: 
  597: \ Target compilation primitives                        06oct92py
  598: \ included A!                                          16may93jaw
  599: 
  600: : here  ( -- there )    there ;
  601: : allot ( n -- )        tdp +! ;
  602: : ,     ( w -- )        T here H tcell T allot  ! H T here drop H ;
  603: : c,    ( char -- )     T here    1 allot c! H ;
  604: : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;
  605: : cfalign ( -- )
  606:     T here H cfalign+ 0 ?DO  bl T c, H LOOP ;
  607: 
  608: : A!                    dup relon T ! H ;
  609: : A,    ( w -- )        T here H relon T , H ;
  610: 
  611: >CROSS
  612: 
  613: : tcmove ( source dest len -- )
  614: \G cmove in target memory
  615:   bounds
  616:   ?DO  dup T c@ H I T c! H 1+
  617:   LOOP  drop ;
  618: 
  619: >TARGET
  620: H also Forth definitions \ ." asm: " order
  621: 
  622: : X 	also target bl word find
  623: 	IF	state @ IF compile,
  624: 		ELSE execute THEN
  625: 	ELSE	previous ABORT" Cross: access method not supported!"
  626: 	THEN 
  627: 	previous ; immediate
  628: 
  629: [IFDEF] asm-include asm-include [THEN] hex
  630: 
  631: previous
  632: >CROSS H
  633: 
  634: \ \ --------------------        Compiler Plug Ins               01aug97jaw
  635: 
  636: Defer lit, ( n -- )
  637: Defer alit, ( n -- )
  638: Defer branch, ( target-addr -- )
  639: Defer ?branch, ( target-addr -- )
  640: Defer branchmark, ( -- branch-addr )
  641: Defer ?branchmark, ( -- branch-addr )
  642: Defer branchto,
  643: Defer branchtoresolve, ( branch-addr -- )
  644: Defer branchfrom, ( -- )
  645: Defer branchtomark, ( -- target-addr )
  646: Defer colon, ( tcfa -- )		\ compiles call to tcfa at current position
  647: Defer colon-resolve ( tcfa addr -- )
  648: Defer addr-resolve ( target-addr addr -- )
  649: 
  650: [IFUNDEF] ca>native
  651: defer ca>native	
  652: [THEN]
  653: 
  654: >TARGET
  655: DEFER >body             \ we need the system >body
  656: 			\ and the target >body
  657: >CROSS
  658: T 2 cells H VALUE xt>body
  659: DEFER doprim,
  660: DEFER docol,     \ compiles start of definition and doer
  661: DEFER doer,		
  662: DEFER fini,      \ compiles end of definition ;s
  663: DEFER doeshandler,
  664: DEFER dodoes,
  665: 
  666: DEFER ]comp     \ starts compilation
  667: DEFER comp[     \ ends compilation
  668: 
  669: : (cc) T a, H ;			' (cc) IS colon,
  670: : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve
  671: : (ar) T ! H ;			' (ar) IS addr-resolve
  672: 
  673: >TARGET
  674: : compile, colon, ;
  675: >CROSS
  676: 
  677: 
  678: 
  679: \ resolve structure
  680: 
  681: : >next ;		\ link to next field
  682: : >tag cell+ ;		\ indecates type of reference: 0: call, 1: address
  683: : >taddr cell+ cell+ ;
  684: : >ghost 3 cells + ;
  685: 
  686: : refered ( ghost tag -- )
  687:   swap >r here r@ >link @ , r@ >link ! ( tag ) ,
  688:   T here aligned H , r> drop  last-header-ghost @ , ;
  689: 
  690: Defer resolve-warning
  691: 
  692: : reswarn-test ( ghost res-struct -- ghost res-struct )
  693:   over cr ." Resolving " >ghostname type dup ."  in " >ghost @ >ghostname type ;
  694: 
  695: : reswarn-forward ( ghost res-struct -- ghost res-struct )
  696:   over warnhead >ghostname type dup ."  is referenced in " 
  697:   >ghost @ >ghostname type ;
  698: 
  699: \ ' reswarn-test IS resolve-warning
  700:  
  701: \ resolve                                              14oct92py
  702: 
  703:  : resolve-loop ( ghost tcfa -- ghost tcfa )
  704:   >r dup >link
  705:   BEGIN @ dup WHILE 
  706: 	resolve-warning 
  707: 	r@ over >taddr @ 
  708: 	2 pick >tag @
  709: 	IF	addr-resolve
  710: 	ELSE	colon-resolve
  711: 	THEN
  712:   REPEAT drop r> ;
  713: 
  714: \ : resolve-loop ( ghost tcfa -- ghost tcfa )
  715: \  >r dup >link @
  716: \  BEGIN  dup  WHILE  dup T @ H r@ rot T ! H REPEAT  drop r> ;
  717: 
  718: \ exists                                                9may93jaw
  719: 
  720: Variable TWarnings
  721: TWarnings on
  722: Variable Exists-Warnings
  723: Exists-Warnings on
  724: 
  725: : exists ( ghost tcfa -- )
  726:   over GhostNames
  727:   BEGIN @ dup
  728:   WHILE 2dup cell+ @ =
  729:   UNTIL
  730:         2 cells + count
  731:         TWarnings @ Exists-Warnings @ and
  732:         IF warnhead type ."  exists"
  733:         ELSE 2drop THEN
  734:         drop swap >link !
  735:   ELSE  true abort" CROSS: Ghostnames inconsistent "
  736:   THEN ;
  737: 
  738: : resolve  ( ghost tcfa -- )
  739: \ resolve referencies to ghost with tcfa
  740:   over forward? 0= IF  exists EXIT THEN
  741:   resolve-loop  over >link ! <res> swap >magic ! 
  742:   ['] noop IS resolve-warning 
  743:   ;
  744: 
  745: \ gexecute ghost,                                      01nov92py
  746: 
  747: : is-forward   ( ghost -- )
  748: \  >link dup @ there rot !  T  A,  H ;
  749:   0 refered  -1 colon, ;
  750: 
  751: : is-resolved   ( ghost -- )
  752:   >link @ colon, ; \ compile-call
  753: 
  754: : gexecute   ( ghost -- )
  755:   dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;
  756: 
  757: : addr,  ( ghost -- )
  758:   dup @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
  759: 
  760: \ !! : ghost,     ghost  gexecute ;
  761: 
  762: \ .unresolved                                          11may93jaw
  763: 
  764: variable ResolveFlag
  765: 
  766: \ ?touched                                             11may93jaw
  767: 
  768: : ?touched ( ghost -- flag ) dup forward? swap >link @
  769:                                0 <> and ;
  770: 
  771: : ?resolved  ( ghostname -- )
  772:   dup cell+ @ ?touched
  773:   IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;
  774: 
  775: >MINIMAL
  776: : .unresolved  ( -- )
  777:   ResolveFlag off cr ." Unresolved: "
  778:   Ghostnames
  779:   BEGIN @ dup
  780:   WHILE dup ?resolved
  781:   REPEAT drop ResolveFlag @
  782:   IF
  783:       -1 abort" Unresolved words!"
  784:   ELSE
  785:       ." Nothing!"
  786:   THEN
  787:   cr ;
  788: 
  789: : .stats
  790:   base @ >r decimal
  791:   cr ." named Headers: " headers-named @ . 
  792: \  cr ." MaxRam*" ramdp @ . 
  793: \  cr ." MaxRom*" romdp @ . 
  794:   r> base ! ;
  795: 
  796: >CROSS
  797: \ Header states                                        12dec92py
  798: 
  799: : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
  800: 
  801: VARIABLE ^imm
  802: 
  803: >TARGET
  804: : immediate     40 flag!
  805:                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
  806:                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
  807:                 <imm> ^imm @ ! ;
  808: : restrict      20 flag! ;
  809: 
  810: : isdoer	<do:> last-header-ghost @ >magic ! ;
  811: >CROSS
  812: 
  813: \ ALIAS2 ansforth conform alias                          9may93jaw
  814: 
  815: : ALIAS2 create here 0 , DOES> @ execute ;
  816: \ usage:
  817: \ ' <name> alias2 bla !
  818: 
  819: \ Target Header Creation                               01nov92py
  820: 
  821: >TARGET
  822: : string,  ( addr count -- )
  823:   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
  824: : name,  ( "name" -- )  bl word count T string, cfalign H ;
  825: : view,   ( -- ) ( dummy ) ;
  826: >CROSS
  827: 
  828: \ Target Document Creation (goes to crossdoc.fd)       05jul95py
  829: 
  830: s" doc/crossdoc.fd" r/w create-file throw value doc-file-id
  831: \ contains the file-id of the documentation file
  832: 
  833: : T-\G ( -- )
  834:     source >in @ /string doc-file-id write-line throw
  835:     postpone \ ;
  836: 
  837: Variable to-doc  to-doc on
  838: 
  839: : cross-doc-entry  ( -- )
  840:     to-doc @ tlast @ 0<> and	\ not an anonymous (i.e. noname) header
  841:     IF
  842: 	s" " doc-file-id write-line throw
  843: 	s" make-doc " doc-file-id write-file throw
  844: 	tlast @ >image count $1F and doc-file-id write-file throw
  845: 	>in @
  846: 	[char] ( parse 2drop
  847: 	[char] ) parse doc-file-id write-file throw
  848: 	s"  )" doc-file-id write-file throw
  849: 	[char] \ parse 2drop					
  850: 	T-\G
  851: 	>in !
  852:     THEN ;
  853: 
  854: \ Target TAGS creation
  855: 
  856: s" kernel.TAGS" r/w create-file throw value tag-file-id
  857: \ contains the file-id of the tags file
  858: 
  859: Create tag-beg 2 c,  7F c, bl c,
  860: Create tag-end 2 c,  bl c, 01 c,
  861: Create tag-bof 1 c,  0C c,
  862: 
  863: 2variable last-loadfilename 0 0 last-loadfilename 2!
  864: 	    
  865: : put-load-file-name ( -- )
  866:     loadfilename 2@ last-loadfilename 2@ d<>
  867:     IF
  868: 	tag-bof count tag-file-id write-line throw
  869: 	sourcefilename 2dup
  870: 	tag-file-id write-file throw
  871: 	last-loadfilename 2!
  872: 	s" ,0" tag-file-id write-line throw
  873:     THEN ;
  874: 
  875: : cross-tag-entry  ( -- )
  876:     tlast @ 0<>	\ not an anonymous (i.e. noname) header
  877:     IF
  878: 	put-load-file-name
  879: 	source >in @ min tag-file-id write-file throw
  880: 	tag-beg count tag-file-id write-file throw
  881: 	tlast @ >image count $1F and tag-file-id write-file throw
  882: 	tag-end count tag-file-id write-file throw
  883: 	base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
  884: \	>in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
  885: 	s" ,0" tag-file-id write-line throw
  886: 	base !
  887:     THEN ;
  888: 
  889: \ Check for words
  890: 
  891: Defer skip? ' false IS skip?
  892: 
  893: : defined? ( -- flag ) \ name
  894:     ghost forward? 0= ;
  895: 
  896: : needed? ( -- flag ) \ name
  897: \G returns a false flag when
  898: \G a word is not defined
  899: \G a forward reference exists
  900: \G so the definition is not skipped!
  901:     bl word gfind
  902:     IF dup forward?
  903: 	nip
  904: 	0=
  905:     ELSE  drop true  THEN ;
  906: 
  907: : doer? ( -- flag ) \ name
  908:     ghost >magic @ <do:> = ;
  909: 
  910: : skip-defs ( -- )
  911:     BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
  912: 
  913: \ Target header creation
  914: 
  915: 
  916: VARIABLE CreateFlag CreateFlag off
  917: 
  918: : 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ;
  919: : .sym
  920:   bounds 
  921:   DO I c@ dup
  922: 	CASE	'/ OF drop ." \/" ENDOF
  923: 		'\ OF drop ." \\" ENDOF
  924: 		dup OF emit ENDOF
  925: 	ENDCASE
  926:   LOOP ;
  927: 
  928: : (Theader ( "name" -- ghost )
  929: \  >in @ bl word count type 2 spaces >in !
  930: \ wordheaders will always be compiled to rom
  931:   switchrom
  932:   T align H view,
  933:   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !
  934:   1 headers-named +!	\ Statistic
  935:   >in @ T name, H >in ! T here H tlastcfa !
  936:   \ Symbol table
  937:   \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
  938:   CreateFlag @ IF
  939:        >in @ alias2 swap >in !         \ create alias in target
  940:        >in @ ghost swap >in !
  941:        swap also ghosts ' previous swap !     \ tick ghost and store in alias
  942:        CreateFlag off
  943:   ELSE ghost THEN
  944:   dup Last-Header-Ghost !
  945:   dup >magic ^imm !     \ a pointer for immediate
  946:   Already @ IF  dup >end tdoes !
  947:   ELSE 0 tdoes ! THEN
  948:   80 flag!
  949:   cross-doc-entry cross-tag-entry ;
  950: 
  951: VARIABLE ;Resolve 1 cells allot
  952: \ this is the resolver information from ":"
  953: \ resolving is done by ";"
  954: 
  955: : Theader  ( "name" -- ghost )
  956:   (THeader dup there resolve 0 ;Resolve ! ;
  957: 
  958: >TARGET
  959: : Alias    ( cfa -- ) \ name
  960:     >in @ skip? IF  2drop  EXIT  THEN  >in !
  961:     dup 0< has-prims 0= and
  962:     IF
  963: 	." needs prim: " >in @ bl word count type >in ! cr
  964:     THEN
  965:     (THeader over resolve T A, H 80 flag! ;
  966: : Alias:   ( cfa -- ) \ name
  967:     >in @ skip? IF  2drop  EXIT  THEN  >in !
  968:     dup 0< has-prims 0= and
  969:     IF
  970: 	." needs doer: " >in @ bl word count type >in ! cr
  971:     THEN
  972:     ghost tuck swap resolve <do:> swap >magic ! ;
  973: >CROSS
  974: 
  975: \ Conditionals and Comments                            11may93jaw
  976: 
  977: : ;Cond
  978:   postpone ;
  979:   swap ! ;  immediate
  980: 
  981: : Cond: ( -- ) \ name {code } ;
  982:   atonce on
  983:   ghost
  984:   >exec
  985:   :NONAME ;
  986: 
  987: : restrict? ( -- )
  988: \ aborts on interprete state - ae
  989:   state @ 0= ABORT" CROSS: Restricted" ;
  990: 
  991: : Comment ( -- )
  992:   >in @ atonce on ghost swap >in ! ' swap >exec ! ;
  993: 
  994: Comment (       Comment \
  995: 
  996: \ compile                                              10may93jaw
  997: 
  998: : compile  ( -- ) \ name
  999:   restrict?
 1000:   bl word gfind dup 0= ABORT" CROSS: Can't compile "
 1001:   0> ( immediate? )
 1002:   IF    >exec @ compile,
 1003:   ELSE  postpone literal postpone gexecute  THEN ;
 1004:                                         immediate
 1005: 
 1006: : [G'] 
 1007: \G ticks a ghost and returns its address
 1008:   bl word gfind 0= ABORT" CROSS: Ghost don't exists"
 1009:   state @
 1010:   IF   postpone literal
 1011:   THEN ; immediate
 1012: 
 1013: : ghost>cfa
 1014:   dup forward? ABORT" CROSS: forward " >link @ ;
 1015:                
 1016: >TARGET
 1017: 
 1018: : '  ( -- cfa ) 
 1019: \ returns the target-cfa of a ghost
 1020:   bl word gfind 0= ABORT" CROSS: Ghost don't exists"
 1021:   ghost>cfa ;
 1022: 
 1023: Cond: [']  T ' H alit, ;Cond
 1024: 
 1025: >CROSS
 1026: 
 1027: : [T']
 1028: \ returns the target-cfa of a ghost, or compiles it as literal
 1029:   postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate
 1030: 
 1031: \ \ threading modell					13dec92py
 1032: \ modularized						14jun97jaw
 1033: 
 1034: : fillcfa   ( usedcells -- )
 1035:   T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ;
 1036: 
 1037: : (>body)   ( cfa -- pfa ) xt>body + ;		' (>body) T IS >body H
 1038: 
 1039: : (doer,)   ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ;   ' (doer,) IS doer,
 1040: 
 1041: : (docol,)  ( -- ) [G'] :docol doer, ;		' (docol,) IS docol,
 1042: 
 1043: : (doprim,) ( -- )
 1044:   there xt>body + ca>native T a, H 1 fillcfa ;	' (doprim,) IS doprim,
 1045: 
 1046: : (doeshandler,) ( -- ) 
 1047:   T cfalign H compile :doesjump T 0 , H ; 	' (doeshandler,) IS doeshandler,
 1048: 
 1049: : (dodoes,) ( does-action-ghost -- )
 1050:   ]comp [G'] :dodoes gexecute comp[
 1051:   addr,
 1052:   T here H tcell - reloff 2 fillcfa ;		' (dodoes,) IS dodoes,
 1053: 
 1054: : (lit,) ( n -- )   compile lit T  ,  H ;	' (lit,) IS lit,
 1055: 
 1056: : (alit,) ( n -- )  lit, T here cell - H relon ;	' (alit,) IS alit,
 1057: 
 1058: : (fini,)         compile ;s ;                ' (fini,) IS fini,
 1059: 
 1060: [IFUNDEF] (code) 
 1061: Defer (code)
 1062: Defer (end-code)
 1063: [THEN]
 1064: 
 1065: >TARGET
 1066: : Code
 1067:   defempty?
 1068:   (THeader there resolve
 1069:   [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]
 1070:   doprim, 
 1071:   [THEN]
 1072:   depth (code) ;
 1073: 
 1074: : Code:
 1075:   defempty?
 1076:     ghost dup there ca>native resolve  <do:> swap >magic !
 1077:     depth (code) ;
 1078: 
 1079: : end-code
 1080:     (end-code)
 1081:     depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
 1082:     ELSE true ABORT" CROSS: Stack empty" THEN
 1083:     ;
 1084: 
 1085: Cond: chars ;Cond
 1086: 
 1087: >CROSS
 1088: 
 1089: \ tLiteral                                             12dec92py
 1090: 
 1091: >TARGET
 1092: Cond: \G  T-\G ;Cond
 1093: 
 1094: Cond:  Literal ( n -- )   restrict? lit, ;Cond
 1095: Cond: ALiteral ( n -- )   restrict? alit, ;Cond
 1096: 
 1097: : Char ( "<char>" -- )  bl word char+ c@ ;
 1098: Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond
 1099: 
 1100: \ some special literals					27jan97jaw
 1101: 
 1102: \ !! Known Bug: Special Literals and plug-ins work only correct
 1103: \ on 16 and 32 Bit Targets and 32 Bit Hosts!
 1104: 
 1105: Cond: MAXU
 1106:   restrict? 
 1107:   tcell 1 cells u> 
 1108:   IF	compile lit tcell 0 ?DO FF T c, H LOOP 
 1109:   ELSE	$ffffffff lit, THEN
 1110:   ;Cond
 1111: 
 1112: Cond: MINI
 1113:   restrict?
 1114:   tcell 1 cells u>
 1115:   IF	compile lit bigendian 
 1116:   	IF	80 T c, H tcell 1 ?DO 0 T c, H LOOP 
 1117:   	ELSE  	tcell 1 ?DO 0 T c, H LOOP 80 T c, H
 1118:   	THEN
 1119:   ELSE	tcell 2 = IF $8000 ELSE $80000000 THEN lit, THEN
 1120:   ;Cond
 1121:  
 1122: Cond: MAXI
 1123:  restrict?
 1124:  tcell 1 cells u>
 1125:  IF	compile lit bigendian 
 1126: 	IF 	7F T c, H tcell 1 ?DO FF T c, H LOOP
 1127: 	ELSE 	tcell 1 ?DO FF T c, H LOOP 7F T c, H
 1128:  	THEN
 1129:  ELSE	tcell 2 = IF $7fff ELSE $7fffffff THEN lit, THEN
 1130:  ;Cond
 1131: 
 1132: >CROSS
 1133: \ Target compiling loop                                12dec92py
 1134: \ ">tib trick thrown out                               10may93jaw
 1135: \ number? defined at the top                           11may93jaw
 1136: 
 1137: \ compiled word might leave items on stack!
 1138: : tcom ( in name -- )
 1139:   gfind  ?dup  IF    0> IF    nip >exec @ execute
 1140:                         ELSE  nip gexecute  THEN EXIT THEN
 1141:   number? dup  IF    0> IF swap lit,  THEN  lit,  drop
 1142:                ELSE  2drop >in !
 1143:                ghost gexecute THEN  ;
 1144: 
 1145: >TARGET
 1146: \ : ; DOES>                                            13dec92py
 1147: \ ]                                                     9may93py/jaw
 1148: 
 1149: : ] state on
 1150:     BEGIN
 1151:         BEGIN >in @ bl word
 1152:               dup c@ 0= WHILE 2drop refill 0=
 1153:               ABORT" CROSS: End of file while target compiling"
 1154:         REPEAT
 1155:         tcom
 1156:         state @
 1157:         0=
 1158:     UNTIL ;
 1159: 
 1160: \ by the way: defining a second interpreter (a compiler-)loop
 1161: \             is not allowed if a system should be ans conform
 1162: 
 1163: : : ( -- colon-sys ) \ Name
 1164:   defempty?
 1165:   constflag off \ don't let this flag work over colon defs
 1166: 		\ just to go sure nothing unwanted happens
 1167:   >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
 1168:   (THeader ;Resolve ! there ;Resolve cell+ !
 1169:   docol, ]comp depth T ] H ;
 1170: 
 1171: : :noname ( -- colon-sys )
 1172:   T cfalign H there docol, 0 ;Resolve ! depth T ] H ;
 1173: 
 1174: Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
 1175: 
 1176: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
 1177: 
 1178: >CROSS
 1179: : LastXT ;Resolve @ 0= abort" CROSS: no definition for LastXT"
 1180:          ;Resolve cell+ @ ;
 1181: 
 1182: >TARGET
 1183: 
 1184: Cond: recurse ( -- ) Last-Ghost @ gexecute ;Cond
 1185: 
 1186: Cond: ; ( -- ) restrict?
 1187:                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
 1188:                           ELSE true ABORT" CROSS: Stack empty" THEN
 1189:                fini,
 1190:                comp[
 1191:                state off
 1192:                ;Resolve @
 1193:                IF ;Resolve @ ;Resolve cell+ @ resolve THEN
 1194:                ;Cond
 1195: Cond: [  restrict? state off ;Cond
 1196: 
 1197: >CROSS
 1198: : !does ( does-action -- )
 1199: \ !! zusammenziehen und dodoes, machen!
 1200:     tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
 1201: \ !! geht so nicht, da dodoes, ghost will!
 1202: \     tlastcfa @ >tempdp dodoes, tempdp> ;
 1203: 
 1204: >TARGET
 1205: Cond: DOES> restrict?
 1206:         compile (does>) doeshandler, 
 1207: 	\ resolve words made by builders
 1208: 	tdoes @ ?dup IF  @ T here H resolve THEN
 1209:         ;Cond
 1210: : DOES> switchrom doeshandler, T here H !does depth T ] H ;
 1211: 
 1212: >CROSS
 1213: \ Creation                                             01nov92py
 1214: 
 1215: \ Builder                                               11may93jaw
 1216: 
 1217: : Builder    ( Create-xt do:-xt "name" -- )
 1218: \ builds up a builder in current vocabulary
 1219: \ create-xt is executed when word is interpreted
 1220: \ do:-xt is executet when the created word from builder is executed
 1221: \ for do:-xt an additional entry after the normal ghost-enrys is used
 1222: 
 1223:   >in @ alias2 swap dup >in ! >r >r
 1224:   Make-Ghost rot swap >exec ! ,
 1225:   r> r> >in !
 1226:   also ghosts ' previous swap ! ;
 1227: \  DOES>  dup >exec @ execute ;
 1228: 
 1229: : gdoes,  ( ghost -- )
 1230: \ makes the codefield for a word that is built
 1231:   >end @ dup forward? 0=
 1232:   IF
 1233: 	dup >magic @ <do:> =
 1234: 	IF  doer, EXIT THEN
 1235:   THEN
 1236: \  compile :dodoes gexecute
 1237: \  T here H tcell - reloff 
 1238:   dodoes,
 1239: ;
 1240: 
 1241: : TCreate ( <name> -- )
 1242:   executed-ghost @
 1243:   CreateFlag on
 1244:   create-forward-warn
 1245:   IF ['] reswarn-forward IS resolve-warning THEN
 1246:   Theader >r dup gdoes,
 1247: \ stores execution symantic in the built word
 1248:   >end @ >exec @ r> >exec ! ;
 1249: 
 1250: : RTCreate ( <name> -- )
 1251: \ creates a new word with code-field in ram
 1252:   executed-ghost @
 1253:   CreateFlag on
 1254:   create-forward-warn
 1255:   IF ['] reswarn-forward IS resolve-warning THEN
 1256:   \ make Alias
 1257:   (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )
 1258:   \ store  poiter to code-field
 1259:   switchram T cfalign H
 1260:   there swap T ! H
 1261:   there tlastcfa ! 
 1262:   dup there resolve 0 ;Resolve !
 1263:   >r dup gdoes,
 1264:   >end @ >exec @ r> >exec ! ;
 1265: 
 1266: : Build:  ( -- [xt] [colon-sys] )
 1267:   :noname postpone TCreate ;
 1268: 
 1269: : BuildSmart:  ( -- [xt] [colon-sys] )
 1270:   :noname
 1271:   [ has-rom [IF] ]
 1272:   postpone RTCreate
 1273:   [ [ELSE] ]
 1274:   postpone TCreate 
 1275:   [ [THEN] ] ;
 1276: 
 1277: : gdoes>  ( ghost -- addr flag )
 1278:   executed-ghost @
 1279:   state @ IF  gexecute true EXIT  THEN
 1280:   >link @ T >body H false ;
 1281: 
 1282: \ DO: ;DO                                               11may93jaw
 1283: \ changed to ?EXIT                                      10may93jaw
 1284: 
 1285: : DO:     ( -- addr [xt] [colon-sys] )
 1286:   here ghostheader
 1287:   :noname postpone gdoes> postpone ?EXIT ;
 1288: 
 1289: : by:     ( -- addr [xt] [colon-sys] ) \ name
 1290:   ghost
 1291:   :noname postpone gdoes> postpone ?EXIT ;
 1292: 
 1293: : ;DO ( addr [xt] [colon-sys] -- addr )
 1294:   postpone ;    ( S addr xt )
 1295:   over >exec ! ; immediate
 1296: 
 1297: : by      ( -- addr ) \ Name
 1298:   ghost >end @ ;
 1299: 
 1300: >TARGET
 1301: \ Variables and Constants                              05dec92py
 1302: 
 1303: Build:  ( n -- ) ;
 1304: by: :docon ( ghost -- n ) T @ H ;DO
 1305: Builder (Constant)
 1306: 
 1307: Build:  ( n -- ) T , H ;
 1308: by (Constant)
 1309: Builder Constant
 1310: 
 1311: Build:  ( n -- ) T A, H ;
 1312: by (Constant)
 1313: Builder AConstant
 1314: 
 1315: Build:  ( d -- ) T , , H ;
 1316: DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
 1317: Builder 2Constant
 1318: 
 1319: BuildSmart: ;
 1320: by: :dovar ( ghost -- addr ) ;DO
 1321: Builder Create
 1322: 
 1323: has-rom [IF]
 1324: Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 1325: by (Constant)
 1326: Builder Variable
 1327: [ELSE]
 1328: Build: T 0 , H ;
 1329: by Create
 1330: Builder Variable
 1331: [THEN]
 1332: 
 1333: has-rom [IF]
 1334: Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 1335: by (Constant)
 1336: Builder AVariable
 1337: [ELSE]
 1338: Build: T 0 A, H ;
 1339: by Create
 1340: Builder AVariable
 1341: [THEN]
 1342: 
 1343: \ User variables                                       04may94py
 1344: 
 1345: >CROSS
 1346: Variable tup  0 tup !
 1347: Variable tudp 0 tudp !
 1348: : u,  ( n -- udp )
 1349:   tup @ tudp @ + T  ! H
 1350:   tudp @ dup T cell+ H tudp ! ;
 1351: : au, ( n -- udp )
 1352:   tup @ tudp @ + T A! H
 1353:   tudp @ dup T cell+ H tudp ! ;
 1354: >TARGET
 1355: 
 1356: Build: T 0 u, , H ;
 1357: by: :douser ( ghost -- up-addr )  T @ H tup @ + ;DO
 1358: Builder User
 1359: 
 1360: Build: T 0 u, , 0 u, drop H ;
 1361: by User
 1362: Builder 2User
 1363: 
 1364: Build: T 0 au, , H ;
 1365: by User
 1366: Builder AUser
 1367: 
 1368: BuildSmart: T , H ;
 1369: by (Constant)
 1370: Builder Value
 1371: 
 1372: BuildSmart: T A, H ;
 1373: by (Constant)
 1374: Builder AValue
 1375: 
 1376: BuildSmart:  ( -- ) [T'] noop T A, H ;
 1377: by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 1378: Builder Defer
 1379: 
 1380: BuildSmart:  ( inter comp -- ) swap T immediate A, A, H ;
 1381: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 1382: Builder interpret/compile:
 1383: 
 1384: \ Sturctures                                           23feb95py
 1385: 
 1386: >CROSS
 1387: : nalign ( addr1 n -- addr2 )
 1388: \ addr2 is the aligned version of addr1 wrt the alignment size n
 1389:  1- tuck +  swap invert and ;
 1390: >TARGET
 1391: 
 1392: Build: ;
 1393: by: :dofield T @ H + ;DO
 1394: Builder (Field)
 1395: 
 1396: Build: ( align1 offset1 align size "name" --  align2 offset2 )
 1397:     rot dup T , H ( align1 align size offset1 )
 1398:     + >r nalign r> ;
 1399: by (Field)
 1400: Builder Field
 1401: 
 1402: : struct  T 1 chars 0 H ;
 1403: : end-struct  T 2Constant H ;
 1404: 
 1405: : cell% ( n -- size align )
 1406:     T 1 cells H dup ;
 1407: 
 1408: \ ' 2Constant Alias2 end-struct
 1409: \ 0 1 T Chars H 2Constant struct
 1410: 
 1411: 0 [IF]
 1412: 
 1413: \ structural conditionals                              17dec92py
 1414: 
 1415: >CROSS
 1416: : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
 1417: : sys?        ( sys -- sys )    dup 0= ?struc ;
 1418: : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
 1419: 
 1420: : branchoffset ( src dest -- ) - ;
 1421: : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;
 1422: : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;
 1423: >TARGET
 1424: 
 1425: \ Structural Conditionals                              12dec92py
 1426: 
 1427: Cond: BUT       restrict? sys? swap ;Cond
 1428: Cond: YET       restrict? sys? dup ;Cond
 1429: 
 1430: >CROSS
 1431: Variable tleavings
 1432: >TARGET
 1433: 
 1434: Cond: DONE   ( addr -- )  restrict? tleavings @
 1435:       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT
 1436:       tleavings ! drop ;Cond
 1437: 
 1438: >CROSS
 1439: : (leave  T here H tleavings @ T , H  tleavings ! ;
 1440: >TARGET
 1441: 
 1442: Cond: LEAVE     restrict? compile branch (leave ;Cond
 1443: Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond
 1444: 
 1445: \ Structural Conditionals                              12dec92py
 1446: 
 1447: Cond: AHEAD     restrict? compile branch >mark ;Cond
 1448: Cond: IF        restrict? compile ?branch >mark ;Cond
 1449: Cond: THEN      restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond
 1450: Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond
 1451: 
 1452: Cond: BEGIN     restrict? T branchto, here ( dup ." B" hex. ) H ;Cond
 1453: Cond: WHILE     restrict? sys? compile IF swap ;Cond
 1454: Cond: AGAIN     restrict? sys? compile branch <resolve ;Cond
 1455: Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond
 1456: Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
 1457: 
 1458: Cond: CASE      restrict? 0 ;Cond
 1459: Cond: OF        restrict? 1+ >r compile over compile =
 1460:                 compile IF compile drop r> ;Cond
 1461: Cond: ENDOF     restrict? >r compile ELSE r> ;Cond
 1462: Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond
 1463: 
 1464: \ Structural Conditionals                              12dec92py
 1465: 
 1466: Cond: DO        restrict? compile (do)   T here H ;Cond
 1467: Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond
 1468: Cond: FOR       restrict? compile (for)  T here H ;Cond
 1469: 
 1470: >CROSS
 1471: : loop]   dup <resolve tcell - compile DONE compile unloop ;
 1472: >TARGET
 1473: 
 1474: Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond
 1475: Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond
 1476: Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond
 1477: 
 1478: [ELSE]
 1479: 
 1480: \ structural conditionals                              17dec92py
 1481: 
 1482: >CROSS
 1483: : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
 1484: : sys?        ( sys -- sys )    dup 0= ?struc ;
 1485: : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
 1486: 
 1487: : branchoffset ( src dest -- ) - ;
 1488: 
 1489: : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;
 1490: 
 1491: : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;
 1492: 
 1493: :noname compile branch T here branchoffset , H ; IS branch,
 1494: :noname compile ?branch T here branchoffset , H ; IS ?branch,
 1495: :noname compile branch T here 0 , H ; IS branchmark,
 1496: :noname compile ?branch T here 0 , H ; IS  ?branchmark,
 1497: :noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve,
 1498: :noname branchto, T here H ; IS branchtomark,
 1499: 
 1500: >TARGET
 1501: 
 1502: \ Structural Conditionals                              12dec92py
 1503: 
 1504: Cond: BUT       restrict? sys? swap ;Cond
 1505: Cond: YET       restrict? sys? dup ;Cond
 1506: 
 1507: >CROSS
 1508: Variable tleavings
 1509: >TARGET
 1510: 
 1511: Cond: DONE   ( addr -- )  restrict? tleavings @
 1512:       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT
 1513:       tleavings ! drop ;Cond
 1514: 
 1515: >CROSS
 1516: : (leave  T here H tleavings @ T , H  tleavings ! ;
 1517: >TARGET
 1518: 
 1519: Cond: LEAVE     restrict? compile branch (leave ;Cond
 1520: Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond
 1521: 
 1522: \ Structural Conditionals                              12dec92py
 1523: 
 1524: Cond: AHEAD     restrict? branchmark, ;Cond
 1525: Cond: IF        restrict? ?branchmark, ;Cond
 1526: Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond
 1527: Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond
 1528: 
 1529: Cond: BEGIN     restrict? branchtomark, ;Cond
 1530: Cond: WHILE     restrict? sys? compile IF swap ;Cond
 1531: Cond: AGAIN     restrict? sys? branch, ;Cond
 1532: Cond: UNTIL     restrict? sys? ?branch, ;Cond
 1533: Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
 1534: 
 1535: Cond: CASE      restrict? 0 ;Cond
 1536: Cond: OF        restrict? 1+ >r compile over compile =
 1537:                 compile IF compile drop r> ;Cond
 1538: Cond: ENDOF     restrict? >r compile ELSE r> ;Cond
 1539: Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond
 1540: 
 1541: \ Structural Conditionals                              12dec92py
 1542: 
 1543: Cond: DO        restrict? compile (do)   T here H ;Cond
 1544: Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond
 1545: Cond: FOR       restrict? compile (for)  T here H ;Cond
 1546: 
 1547: >CROSS
 1548: : loop]   dup <resolve tcell - compile DONE compile unloop ;
 1549: >TARGET
 1550: 
 1551: Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond
 1552: Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond
 1553: Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond
 1554: 
 1555: [THEN]
 1556: 
 1557: \ String words                                         23feb93py
 1558: 
 1559: : ,"            [char] " parse T string, align H ;
 1560: 
 1561: Cond: ."        restrict? compile (.")     T ," H ;Cond
 1562: Cond: S"        restrict? compile (S")     T ," H ;Cond
 1563: Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond
 1564: 
 1565: Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 1566: : IS            T ' >body ! H ;
 1567: Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 1568: : TO            T ' >body ! H ;
 1569: 
 1570: Cond: defers	T ' >body @ compile, H ;Cond
 1571: : on		T -1 swap ! H ; 
 1572: : off   	T 0 swap ! H ;
 1573: 
 1574: \ LINKED ERR" ENV" 2ENV"                                18may93jaw
 1575: 
 1576: \ linked list primitive
 1577: : linked        T here over @ A, swap ! H ;
 1578: : chained	T linked A, H ;
 1579: 
 1580: : err"   s" ErrLink linked" evaluate T , H
 1581:          [char] " parse T string, align H ;
 1582: 
 1583: : env"  [char] " parse s" EnvLink linked" evaluate
 1584:         T string, align , H ;
 1585: 
 1586: : 2env" [char] " parse s" EnvLink linked" evaluate
 1587:         here >r T string, align , , H
 1588:         r> dup T c@ H 80 and swap T c! H ;
 1589: 
 1590: \ compile must be last                                 22feb93py
 1591: 
 1592: Cond: compile ( -- ) restrict? \ name
 1593:       bl word gfind dup 0= ABORT" CROSS: Can't compile"
 1594:       0> IF    gexecute
 1595:          ELSE  dup >magic @ <imm> =
 1596:                IF   gexecute
 1597:                ELSE compile (compile) gexecute THEN THEN ;Cond
 1598: 
 1599: Cond: postpone ( -- ) restrict? \ name
 1600:       bl word gfind dup 0= ABORT" CROSS: Can't compile"
 1601:       0> IF    gexecute
 1602:          ELSE  dup >magic @ <imm> =
 1603:                IF   gexecute
 1604:                ELSE compile (compile) gexecute THEN THEN ;Cond
 1605: 
 1606: >MINIMAL
 1607: also minimal
 1608: \ Usefull words                                        13feb93py
 1609: 
 1610: : KB  400 * ;
 1611: 
 1612: \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
 1613: 
 1614: : defined? defined? ;
 1615: : needed? needed? ;
 1616: : doer? doer? ;
 1617: 
 1618: \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too
 1619: 
 1620: : directive? 
 1621:   bl word count [ ' target >wordlist ] aliteral search-wordlist 
 1622:   dup IF nip THEN ;
 1623: 
 1624: : [IFDEF]  >in @ directive? swap >in !
 1625: 	   0= IF defined? ELSE name 2drop true THEN
 1626: 	   postpone [IF] ;
 1627: 
 1628: : [IFUNDEF] defined? 0= postpone [IF] ;
 1629: 
 1630: \ C: \- \+ Conditional Compiling                         09jun93jaw
 1631: 
 1632: : C: >in @ defined? 0=
 1633:      IF    >in ! T : H
 1634:      ELSE drop
 1635:         BEGIN bl word dup c@
 1636:               IF   count comment? s" ;" compare 0= ?EXIT
 1637:               ELSE refill 0= ABORT" CROSS: Out of Input while C:"
 1638:               THEN
 1639:         AGAIN
 1640:      THEN ;
 1641: 
 1642: also minimal
 1643: 
 1644: \G doesn't skip line when bit is set in debugmask
 1645: : \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ;
 1646: 
 1647: \G interprets the line if word is not defined
 1648: : \- defined? IF postpone \ THEN ;
 1649: 
 1650: \G interprets the line if word is defined
 1651: : \+ defined? 0= IF postpone \ THEN ;
 1652: 
 1653: Cond: \- \- ;Cond
 1654: Cond: \+ \+ ;Cond
 1655: Cond: \D \D ;Cond
 1656: 
 1657: : ?? bl word find IF execute ELSE drop 0 THEN ;
 1658: 
 1659: : needed:
 1660: \G defines ghost for words that we want to be compiled
 1661:   BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
 1662: 
 1663: : [IF]   postpone [IF] ;
 1664: : [THEN] postpone [THEN] ;
 1665: : [ELSE] postpone [ELSE] ;
 1666: 
 1667: Cond: [IF]      [IF] ;Cond
 1668: Cond: [IFDEF]   [IFDEF] ;Cond
 1669: Cond: [IFUNDEF] [IFUNDEF] ;Cond
 1670: Cond: [THEN]    [THEN] ;Cond
 1671: Cond: [ELSE]    [ELSE] ;Cond
 1672: 
 1673: previous
 1674: 
 1675: \ save-cross                                           17mar93py
 1676: 
 1677: >CROSS
 1678: Create magic  s" Gforth10" here over allot swap move
 1679: 
 1680: char 1 bigendian + tcell + magic 7 + c!
 1681: 
 1682: : save-cross ( "image-name" "binary-name" -- )
 1683:   bl parse ." Saving to " 2dup type cr
 1684:   w/o bin create-file throw >r
 1685:   TNIL IF
 1686:       s" #! "   r@ write-file throw
 1687:       bl parse  r@ write-file throw
 1688:       s"  -i"   r@ write-file throw
 1689:       #lf       r@ emit-file throw
 1690:       r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
 1691:       ?do
 1692: 	  bl over emit-file throw
 1693:       loop
 1694:       drop
 1695:       magic 8       r@ write-file throw \ write magic
 1696:   ELSE
 1697:       bl parse 2drop
 1698:   THEN
 1699:   image @ there 
 1700:   r@ write-file throw \ write image
 1701:   TNIL IF
 1702:       bit$  @ there 1- tcell>bit rshift 1+
 1703:                 r@ write-file throw \ write tags
 1704:   THEN
 1705:   r> close-file throw ;
 1706: 
 1707: : save-region ( addr len -- )
 1708:   bl parse w/o bin create-file throw >r
 1709:   swap image @ + swap r@ write-file throw
 1710:   r> close-file throw ;
 1711: 
 1712: \ words that should be in minimal
 1713: 
 1714: create s-buffer 50 chars allot
 1715: 
 1716: >MINIMAL
 1717: also minimal
 1718: 
 1719: bigendian Constant bigendian
 1720: : here there ;
 1721: : >ram >ram ;
 1722: : >rom >rom ;
 1723: : >auto >auto ;
 1724: : >tempdp >tempdp ;
 1725: : tempdp> tempdp> ;
 1726: : const constflag on ;
 1727: : warnings name 3 = 0= twarnings ! drop ;
 1728: 
 1729: 
 1730: : save-cross save-cross ;
 1731: : save-region save-region ;
 1732: : tdump swap >image swap dump ;
 1733: 
 1734: also forth 
 1735: [IFDEF] Label           : Label defempty? Label ; [THEN] 
 1736: [IFDEF] start-macros    : start-macros defempty? start-macros ; [THEN]
 1737: [IFDEF] builttag	: builttag builttag ;	[THEN]
 1738: previous
 1739: 
 1740: : s" [char] " parse s-buffer place s-buffer count ; \ for environment?
 1741: : + + ;
 1742: : 1+ 1 + ;
 1743: : 2+ 2 + ;
 1744: : or or ;
 1745: : 1- 1- ;
 1746: : - - ;
 1747: : and and ;
 1748: : or or ;
 1749: : 2* 2* ;
 1750: : * * ;
 1751: : / / ;
 1752: : dup dup ;
 1753: : over over ;
 1754: : swap swap ;
 1755: : rot rot ;
 1756: : drop drop ;
 1757: : =   = ;
 1758: : 0=   0= ;
 1759: : lshift lshift ;
 1760: : 2/ 2/ ;
 1761: : . . ;
 1762: 
 1763: : all-words    ['] false    IS skip? ;
 1764: : needed-words ['] needed?  IS skip? ;
 1765: : undef-words  ['] defined? IS skip? ;
 1766: 
 1767: : \  postpone \ ;  immediate
 1768: : \G T-\G ; immediate
 1769: : (  postpone ( ;  immediate
 1770: : include bl word count included ;
 1771: : require require ;
 1772: : .( [char] ) parse type ;
 1773: : ." [char] " parse type ;
 1774: : cr cr ;
 1775: 
 1776: : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
 1777: only forth also minimal definitions
 1778: 
 1779: \ cross-compiler words
 1780: 
 1781: : decimal       decimal ;
 1782: : hex           hex ;
 1783: 
 1784: : tudp          T tudp H ;
 1785: : tup           T tup H ;
 1786: 
 1787: : doc-off       false T to-doc H ! ;
 1788: : doc-on        true  T to-doc H ! ;
 1789: [IFDEF] dbg : dbg dbg ; [THEN]
 1790: 
 1791: minimal
 1792: 
 1793: \ for debugging...
 1794: : order         order ;
 1795: : hwords         words ;
 1796: : words 	also ghosts words previous ;
 1797: : .s            .s ;
 1798: : bye           bye ;
 1799: 
 1800: \ turnkey direction
 1801: : H forth ; immediate
 1802: : T minimal ; immediate
 1803: : G ghosts ; immediate
 1804: 
 1805: : turnkey  0 set-order also Target definitions
 1806:            also Minimal also ;
 1807: 
 1808: \ these ones are pefered:
 1809: 
 1810: : lock   turnkey ;
 1811: : unlock forth also cross ;
 1812: 
 1813: : [[ also unlock ;
 1814: : ]] previous previous ;
 1815: 
 1816: unlock definitions also minimal
 1817: : lock   lock ;
 1818: lock

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>