Annotation of gforth/cross.fs, revision 1.53

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

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