Annotation of gforth/cross.fs, revision 1.52

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

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