\ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) \ Copyright (C) 1995 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License \ as published by the Free Software Foundation; either version 2 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, \ but WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License \ along with this program; if not, write to the Free Software \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. \ Log: \ changed in ; [ to state off 12may93jaw \ included place +place 12may93jaw \ for a created word (variable, constant...) \ is now an alias in the target voabulary. \ this means it is no longer necessary to \ switch between vocabularies for variable \ initialization 12may93jaw \ discovered error in DOES> \ replaced !does with (;code) 16may93jaw \ made complete redesign and \ introduced two vocs method \ to be asure that the right words \ are found 08jun93jaw \ btw: ! works not with 16 bit \ targets 09jun93jaw \ added: 2user and value 11jun93jaw \ needed? works better now!!! 01mar97jaw \ mach file is only loaded into target \ cell corrected \ romable extansions 27apr97-5jun97jaw hex \ the defualt base for the cross-compiler is hex !! Warnings off \ words that are generaly useful : >wordlist ( vocabulary-xt -- wordlist-struct ) also execute get-order swap >r 1- set-order r> ; : umax 2dup u< IF swap THEN drop ; : umin 2dup u> IF swap THEN drop ; : string, ( c-addr u -- ) \ puts down string as cstring dup c, here swap chars dup allot move ; : SetValue ( n -- ) \G Same behaviour as "Value" when the is not defined \G Same behaviour as "to" when is defined \G SetValue searches in the current vocabulary save-input bl word >r restore-input throw r> count get-current search-wordlist IF bl word drop >body ! ELSE Value THEN ; : DefaultValue ( n -- ) \G Same behaviour as "Value" when the is not defined \G SetValue searches in the current vocabulary save-input bl word >r restore-input throw r> count get-current search-wordlist IF bl word drop drop drop ELSE Value THEN ; hex Vocabulary Cross Vocabulary Target Vocabulary Ghosts VOCABULARY Minimal only Forth also Target also also definitions Forth : T previous Cross also Target ; immediate : G Ghosts ; immediate : H previous Forth also Cross ; immediate forth definitions : T previous Cross also Target ; immediate : G Ghosts ; immediate : >cross also Cross definitions previous ; : >target also Target definitions previous ; : >minimal also Minimal definitions previous ; H >CROSS \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are \ for cross-compiling \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!! : comment? ( c-addr u -- c-addr u ) 2dup s" (" compare 0= IF postpone ( ELSE 2dup s" \" compare 0= IF postpone \ THEN THEN ; \ Begin CROSS COMPILER: \ \ -------------------- Error Handling 05aug97jaw \ Flags also forth definitions \ these values may be predefined before \ the cross-compiler is loaded false DefaultValue stack-warn \ check on empty stack at any definition false DefaultValue create-forward-warn \ warn on forward declaration of created words [IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN] [IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN] previous >CROSS : .sourcepos cr sourcefilename type ." :" base @ decimal sourceline# . base ! ; : warnhead \G display error-message head \G perhaps with linenumber and filename .sourcepos ." Warning: " ; : empty? depth IF .sourcepos ." Stack not empty!" THEN ; stack-warn [IF] : defempty? empty? ; [ELSE] : defempty? ; immediate [THEN] \ \ GhostNames Ghosts 9may93jaw \ second name source to search trough list VARIABLE GhostNames 0 GhostNames ! : GhostName ( -- addr ) here GhostNames @ , GhostNames ! here 0 , bl word count \ 2dup type space string, \ !! cfalign ? align ; \ Ghost Builder 06oct92py \ new version with temp variable 10may93jaw VARIABLE VocTemp : previous VocTemp @ set-current ; hex 4711 Constant 4712 Constant 4713 Constant 4714 Constant \ iForth makes only immediate directly after create \ make atonce trick! ? Variable atonce atonce off : NoExec true ABORT" CROSS: Don't execute ghost" ; : GhostHeader , 0 , ['] NoExec , ; : >magic ; \ type of ghost : >link cell+ ; \ pointer where ghost is in target, or if unresolved \ points to the where we have to resolve (linked-list) : >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost : >end 3 cells + ; \ room for additional tags \ for builder (create, variable...) words the \ execution symantics of words built are placed here Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes> Variable last-ghost \ last ghost that is created Variable last-header-ghost \ last ghost definitions with header : Make-Ghost ( "name" -- ghost ) >in @ GhostName swap >in ! dup last-ghost ! DOES> dup executed-ghost ! >exec @ execute ; \ ghost words 14oct92py \ changed: 10may93py/jaw : gfind ( string -- ghost true/1 / string false ) \ searches for string in word-list ghosts dup count [ ' ghosts >wordlist ] ALiteral search-wordlist dup IF >r >body nip r> THEN ; : gdiscover ( xt -- ghost true | xt false ) GhostNames BEGIN @ dup WHILE 2dup cell+ @ dup >magic @ <> >r >link @ = r> and IF cell+ @ nip true EXIT THEN REPEAT drop false ; VARIABLE Already : ghost ( "name" -- ghost ) Already off >in @ bl word gfind IF Already on nip EXIT THEN drop >in ! Make-Ghost ; : >ghostname ( ghost -- adr len ) GhostNames BEGIN @ dup WHILE 2dup cell+ @ = UNTIL nip 2 cells + count ELSE 2drop true abort" CROSS: Ghostnames inconsistent" THEN ; ' >ghostname ALIAS @name : forward? ( ghost -- flag ) >magic @ = ; \ Predefined ghosts 12dec92py ghost 0= drop ghost branch ghost ?branch 2drop ghost (do) ghost (?do) 2drop ghost (for) drop ghost (loop) ghost (+loop) 2drop ghost (next) drop ghost unloop ghost ;S 2drop ghost lit ghost (compile) ghost ! 2drop drop ghost (does>) ghost noop 2drop ghost (.") ghost (S") ghost (ABORT") 2drop drop ghost ' drop ghost :docol ghost :doesjump ghost :dodoes 2drop drop ghost over ghost = ghost drop 2drop drop ghost - drop \ \ Parameter for target systems 06oct92py \ we define it ans like... wordlist Constant target-environment VARIABLE env-current \ save information of current dictionary to restore with environ> : >ENVIRON get-current env-current ! target-environment set-current ; : ENVIRON> env-current @ set-current ; >TARGET : environment? target-environment search-wordlist IF execute true ELSE false THEN ; : e? name T environment? H 0= ABORT" environment variable not defined!" ; : has? name T environment? H IF ELSE false THEN ; : $has? T environment? H IF ELSE false THEN ; >ENVIRON true Value cross >TARGET mach-file count included hex >TARGET [IFUNDEF] has-interpreter true Value has-interpreter [THEN] [IFUNDEF] itc true Value itc [THEN] [IFUNDEF] has-rom false Value has-rom [THEN] >CROSS \ \ Create additional parameters 19jan95py T NIL Constant TNIL cell Constant tcell cell<< Constant tcell<< cell>bit Constant tcell>bit bits/byte Constant tbits/byte float Constant tfloat 1 bits/byte lshift Constant maxbyte H \ Variables 06oct92py Variable image Variable tlast TNIL tlast ! \ Last name field Variable tlastcfa \ Last code field Variable tdoes \ Resolve does> calls Variable bit$ \ statistics 10jun97jaw Variable headers-named 0 headers-named ! Variable user-vars 0 user-vars ! \ Memory initialisation 05dec92py [IFDEF] Memory \ Memory is a bigFORTH feature also Memory : initmem ( var len -- ) 2dup swap handle! >r @ r> erase ; toss [ELSE] : initmem ( var len -- ) tuck allocate abort" CROSS: No memory for target" ( len var adr ) dup rot ! ( len adr ) swap erase ; [THEN] \ MakeKernal 12dec92py : makekernel ( targetsize -- targetsize ) bit$ over 1- tcell>bit rshift 1+ initmem image over initmem ; >MINIMAL : makekernel makekernel ; >CROSS \ memregion.fs Variable last-defined-region \ pointer to last defined region Variable region-link \ linked list with all regions Variable mirrored-link \ linked list for mirrored regions 0 dup mirrored-link ! region-link ! : >rdp 2 cells + ; : >rlen cell+ ; : >rstart ; : region ( addr len -- ) \G create a new region \ check whether predefined region exists save-input bl word find >r >r restore-input throw r> r> 0= IF \ make region drop save-input create restore-input throw here last-defined-region ! over ( startaddr ) , ( length ) , ( dp ) , region-link linked name string, ELSE \ store new parameters in region bl word drop >body >r r@ last-defined-region ! r@ cell+ ! dup r@ ! r> 2 cells + ! THEN ; : borders ( region -- startaddr endaddr ) \G returns lower and upper region border dup @ swap cell+ @ over + ; : extent ( region -- startaddr len ) \G returns the really used area dup @ swap 2 cells + @ over - ; : area ( region -- startaddr totallen ) \G returns the total area dup @ swap cell+ @ ; : mirrored \G mark a region as mirrored mirrored-link linked last-defined-region @ , ; : .addr base @ >r hex tcell 2 u> IF s>d <# # # # # '. hold # # # # #> type ELSE s>d <# # # # # # #> type THEN r> base ! ; : .regions \G display region statistic \ we want to list the regions in the right order \ so first collect all regions on stack 0 region-link @ BEGIN dup WHILE dup @ REPEAT drop BEGIN dup WHILE cr 3 cells - >r r@ 4 cells + count tuck type 12 swap - 0 max spaces space ." Start: " r@ @ dup .addr space ." End: " r@ 1 cells + @ + .addr space ." DP: " r> 2 cells + @ .addr REPEAT drop s" rom" $has? 0= ?EXIT cr ." Mirrored:" mirrored-link @ BEGIN dup WHILE space dup cell+ @ 4 cells + count type @ REPEAT drop cr ; \ -------- predefined regions 0 0 region address-space \ total memory addressed and used by the target system 0 0 region dictionary \ rom area for the compiler has? rom [IF] 0 0 region ram-dictionary mirrored \ ram area for the compiler [ELSE] ' dictionary ALIAS ram-dictionary [THEN] 0 0 region return-stack 0 0 region data-stack 0 0 region tib-region ' dictionary ALIAS rom-dictionary : setup-target ( -- ) \G initialize targets memory space s" rom" $has? IF \ check for ram and rom... address-space area nip ram-dictionary area nip rom-dictionary area nip and and 0= ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!" THEN address-space area nip IF address-space area ELSE dictionary area THEN dup 0= ABORT" CROSS: define at least address-space or dictionary!!" + makekernel drop ; \ switched tdp for rom support 03jun97jaw \ second value is here to store some maximal value for statistics \ tempdp is also embedded here but has nothing to do with rom support \ (needs switched dp) variable tempdp 0 , \ temporary dp for resolving variable tempdp-save 0 [IF] variable romdp 0 , \ Dictionary-Pointer for ramarea variable ramdp 0 , \ Dictionary-Pointer for romarea \ variable sramdp \ start of ram-area for forth variable sromdp \ start of rom-area for forth [THEN] 0 value tdp variable fixed \ flag: true: no automatic switching \ false: switching is done automatically \ Switch-Policy: \ \ a header is always compiled into rom \ after a created word (create and variable) compilation goes to ram \ \ Be careful: If you want to make the data behind create into rom \ you have to put >rom before create! variable constflag constflag off : (switchram) fixed @ ?EXIT has-rom 0= ?EXIT ram-dictionary >rdp to tdp ; : switchram constflag @ IF constflag off ELSE (switchram) THEN ; : switchrom fixed @ ?EXIT rom-dictionary >rdp to tdp ; : >tempdp ( addr -- ) tdp tempdp-save ! tempdp to tdp tdp ! ; : tempdp> ( -- ) tempdp-save @ to tdp ; : >ram fixed off (switchram) fixed on ; : >rom fixed off switchrom fixed on ; : >auto fixed off switchrom ; \ : romstart dup sromdp ! romdp ! ; \ : ramstart dup sramdp ! ramdp ! ; \ default compilation goed to rom \ when romable support is off, only the rom switch is used (!!) >auto : there tdp @ ; >TARGET \ \ Target Memory Handling \ Byte ordering and cell size 06oct92py : cell+ tcell + ; : cells tcell<< lshift ; : chars ; : char+ 1 + ; : floats tfloat * ; >CROSS : cell/ tcell<< rshift ; >TARGET 20 CONSTANT bl \ TNIL Constant NIL >CROSS bigendian [IF] : S! ( n addr -- ) >r s>d r> tcell bounds swap 1- DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; : S@ ( addr -- n ) >r 0 0 r> tcell bounds DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; [ELSE] : S! ( n addr -- ) >r s>d r> tcell bounds DO maxbyte ud/mod rot I c! LOOP 2drop ; : S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; [THEN] >CROSS \ Bit string manipulation 06oct92py \ 9may93jaw CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, : bits ( n -- n ) chars Bittable + c@ ; : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; : +bit ( addr n -- ) >bit over c@ or swap c! ; : -bit ( addr n -- ) >bit invert over c@ and swap c! ; : relon ( taddr -- ) bit$ @ swap cell/ +bit ; : reloff ( taddr -- ) bit$ @ swap cell/ -bit ; \ Target memory access 06oct92py : align+ ( taddr -- rest ) tcell tuck 1- and - [ tcell 1- ] Literal and ; : cfalign+ ( taddr -- rest ) \ see kernel.fs:cfaligned /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ; >TARGET : aligned ( taddr -- ta-addr ) dup align+ + ; \ assumes cell alignment granularity (as GNU C) : cfaligned ( taddr1 -- taddr2 ) \ see kernel.fs dup cfalign+ + ; >CROSS : >image ( taddr -- absaddr ) image @ + ; >TARGET : @ ( taddr -- w ) >image S@ ; : ! ( w taddr -- ) >image S! ; : c@ ( taddr -- char ) >image c@ ; : c! ( char taddr -- ) >image c! ; : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; \ Target compilation primitives 06oct92py \ included A! 16may93jaw : here ( -- there ) there ; : allot ( n -- ) tdp +! ; : , ( w -- ) T here H tcell T allot ! H T here drop H ; : c, ( char -- ) T here 1 allot c! H ; : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; : cfalign ( -- ) T here H cfalign+ 0 ?DO bl T c, H LOOP ; : A! dup relon T ! H ; : A, ( w -- ) T here H relon T , H ; >CROSS : tcmove ( source dest len -- ) \G cmove in target memory bounds ?DO dup T c@ H I T c! H 1+ LOOP drop ; >TARGET H also Forth definitions \ ." asm: " order : X also target bl word find IF state @ IF compile, ELSE execute THEN ELSE previous ABORT" Cross: access method not supported!" THEN previous ; immediate [IFDEF] asm-include asm-include [THEN] hex previous >CROSS H \ \ -------------------- Compiler Plug Ins 01aug97jaw Defer lit, ( n -- ) Defer alit, ( n -- ) Defer branch, ( target-addr -- ) Defer ?branch, ( target-addr -- ) Defer branchmark, ( -- branch-addr ) Defer ?branchmark, ( -- branch-addr ) Defer branchto, Defer branchtoresolve, ( branch-addr -- ) Defer branchfrom, ( -- ) Defer branchtomark, ( -- target-addr ) Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position Defer colon-resolve ( tcfa addr -- ) Defer addr-resolve ( target-addr addr -- ) [IFUNDEF] ca>native defer ca>native [THEN] >TARGET DEFER >body \ we need the system >body \ and the target >body >CROSS T 2 cells H VALUE xt>body DEFER doprim, DEFER docol, \ compiles start of definition and doer DEFER doer, DEFER fini, \ compiles end of definition ;s DEFER doeshandler, DEFER dodoes, DEFER ]comp \ starts compilation DEFER comp[ \ ends compilation : (cc) T a, H ; ' (cc) IS colon, : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve : (ar) T ! H ; ' (ar) IS addr-resolve >TARGET : compile, colon, ; >CROSS \ resolve structure : >next ; \ link to next field : >tag cell+ ; \ indecates type of reference: 0: call, 1: address : >taddr cell+ cell+ ; : >ghost 3 cells + ; : refered ( ghost tag -- ) swap >r here r@ >link @ , r@ >link ! ( tag ) , T here aligned H , r> drop last-header-ghost @ , ; Defer resolve-warning : reswarn-test ( ghost res-struct -- ghost res-struct ) over cr ." Resolving " >ghostname type dup ." in " >ghost @ >ghostname type ; : reswarn-forward ( ghost res-struct -- ghost res-struct ) over warnhead >ghostname type dup ." is referenced in " >ghost @ >ghostname type ; \ ' reswarn-test IS resolve-warning \ resolve 14oct92py : resolve-loop ( ghost tcfa -- ghost tcfa ) >r dup >link BEGIN @ dup WHILE resolve-warning r@ over >taddr @ 2 pick >tag @ IF addr-resolve ELSE colon-resolve THEN REPEAT drop r> ; \ : resolve-loop ( ghost tcfa -- ghost tcfa ) \ >r dup >link @ \ BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ; \ exists 9may93jaw Variable TWarnings TWarnings on Variable Exists-Warnings Exists-Warnings on : exists ( ghost tcfa -- ) over GhostNames BEGIN @ dup WHILE 2dup cell+ @ = UNTIL 2 cells + count TWarnings @ Exists-Warnings @ and IF warnhead type ." exists" ELSE 2drop THEN drop swap >link ! ELSE true abort" CROSS: Ghostnames inconsistent " THEN ; : resolve ( ghost tcfa -- ) \ resolve referencies to ghost with tcfa over forward? 0= IF exists EXIT THEN resolve-loop over >link ! swap >magic ! ['] noop IS resolve-warning ; \ gexecute ghost, 01nov92py : is-forward ( ghost -- ) \ >link dup @ there rot ! T A, H ; 0 refered -1 colon, ; : is-resolved ( ghost -- ) >link @ colon, ; \ compile-call : gexecute ( ghost -- ) dup @ = IF is-forward ELSE is-resolved THEN ; : addr, ( ghost -- ) dup @ = IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; \ !! : ghost, ghost gexecute ; \ .unresolved 11may93jaw variable ResolveFlag \ ?touched 11may93jaw : ?touched ( ghost -- flag ) dup forward? swap >link @ 0 <> and ; : ?resolved ( ghostname -- ) dup cell+ @ ?touched IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ; >MINIMAL : .unresolved ( -- ) ResolveFlag off cr ." Unresolved: " Ghostnames BEGIN @ dup WHILE dup ?resolved REPEAT drop ResolveFlag @ IF -1 abort" Unresolved words!" ELSE ." Nothing!" THEN cr ; : .stats base @ >r decimal cr ." named Headers: " headers-named @ . \ cr ." MaxRam*" ramdp @ . \ cr ." MaxRom*" romdp @ . r> base ! ; >CROSS \ Header states 12dec92py : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; VARIABLE ^imm >TARGET : immediate 40 flag! ^imm @ @ dup = IF drop EXIT THEN <> ABORT" CROSS: Cannot immediate a unresolved word" ^imm @ ! ; : restrict 20 flag! ; : isdoer last-header-ghost @ >magic ! ; >CROSS \ ALIAS2 ansforth conform alias 9may93jaw : ALIAS2 create here 0 , DOES> @ execute ; \ usage: \ ' alias2 bla ! \ Target Header Creation 01nov92py >TARGET : string, ( addr count -- ) dup T c, H bounds ?DO I c@ T c, H LOOP ; : name, ( "name" -- ) bl word count T string, cfalign H ; : view, ( -- ) ( dummy ) ; >CROSS \ Target Document Creation (goes to crossdoc.fd) 05jul95py s" doc/crossdoc.fd" r/w create-file throw value doc-file-id \ contains the file-id of the documentation file : T-\G ( -- ) source >in @ /string doc-file-id write-line throw postpone \ ; Variable to-doc to-doc on : cross-doc-entry ( -- ) to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header IF s" " doc-file-id write-line throw s" make-doc " doc-file-id write-file throw tlast @ >image count $1F and doc-file-id write-file throw >in @ [char] ( parse 2drop [char] ) parse doc-file-id write-file throw s" )" doc-file-id write-file throw [char] \ parse 2drop T-\G >in ! THEN ; \ Target TAGS creation s" kernel.TAGS" r/w create-file throw value tag-file-id \ contains the file-id of the tags file Create tag-beg 2 c, 7F c, bl c, Create tag-end 2 c, bl c, 01 c, Create tag-bof 1 c, 0C c, 2variable last-loadfilename 0 0 last-loadfilename 2! : put-load-file-name ( -- ) loadfilename 2@ last-loadfilename 2@ d<> IF tag-bof count tag-file-id write-line throw sourcefilename 2dup tag-file-id write-file throw last-loadfilename 2! s" ,0" tag-file-id write-line throw THEN ; : cross-tag-entry ( -- ) tlast @ 0<> \ not an anonymous (i.e. noname) header IF put-load-file-name source >in @ min tag-file-id write-file throw tag-beg count tag-file-id write-file throw tlast @ >image count $1F and tag-file-id write-file throw tag-end count tag-file-id write-file throw base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw s" ,0" tag-file-id write-line throw base ! THEN ; \ Check for words Defer skip? ' false IS skip? : defined? ( -- flag ) \ name ghost forward? 0= ; : needed? ( -- flag ) \ name \G returns a false flag when \G a word is not defined \G a forward reference exists \G so the definition is not skipped! bl word gfind IF dup forward? nip 0= ELSE drop true THEN ; : doer? ( -- flag ) \ name ghost >magic @ = ; : skip-defs ( -- ) BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ; \ Target header creation VARIABLE CreateFlag CreateFlag off : 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ; : .sym bounds DO I c@ dup CASE '/ OF drop ." \/" ENDOF '\ OF drop ." \\" ENDOF dup OF emit ENDOF ENDCASE LOOP ; : (Theader ( "name" -- ghost ) \ >in @ bl word count type 2 spaces >in ! \ wordheaders will always be compiled to rom switchrom T align H view, tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! 1 headers-named +! \ Statistic >in @ T name, H >in ! T here H tlastcfa ! \ Symbol table \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! CreateFlag @ IF >in @ alias2 swap >in ! \ create alias in target >in @ ghost swap >in ! swap also ghosts ' previous swap ! \ tick ghost and store in alias CreateFlag off ELSE ghost THEN dup Last-Header-Ghost ! dup >magic ^imm ! \ a pointer for immediate Already @ IF dup >end tdoes ! ELSE 0 tdoes ! THEN 80 flag! cross-doc-entry cross-tag-entry ; VARIABLE ;Resolve 1 cells allot \ this is the resolver information from ":" \ resolving is done by ";" : Theader ( "name" -- ghost ) (THeader dup there resolve 0 ;Resolve ! ; >TARGET : Alias ( cfa -- ) \ name >in @ skip? IF 2drop EXIT THEN >in ! dup 0< has-prims 0= and IF ." needs prim: " >in @ bl word count type >in ! cr THEN (THeader over resolve T A, H 80 flag! ; : Alias: ( cfa -- ) \ name >in @ skip? IF 2drop EXIT THEN >in ! dup 0< has-prims 0= and IF ." needs doer: " >in @ bl word count type >in ! cr THEN ghost tuck swap resolve swap >magic ! ; >CROSS \ Conditionals and Comments 11may93jaw : ;Cond postpone ; swap ! ; immediate : Cond: ( -- ) \ name {code } ; atonce on ghost >exec :NONAME ; : restrict? ( -- ) \ aborts on interprete state - ae state @ 0= ABORT" CROSS: Restricted" ; : Comment ( -- ) >in @ atonce on ghost swap >in ! ' swap >exec ! ; Comment ( Comment \ \ compile 10may93jaw : compile ( -- ) \ name restrict? bl word gfind dup 0= ABORT" CROSS: Can't compile " 0> ( immediate? ) IF >exec @ compile, ELSE postpone literal postpone gexecute THEN ; immediate : [G'] \G ticks a ghost and returns its address bl word gfind 0= ABORT" CROSS: Ghost don't exists" state @ IF postpone literal THEN ; immediate : ghost>cfa dup forward? ABORT" CROSS: forward " >link @ ; >TARGET : ' ( -- cfa ) \ returns the target-cfa of a ghost bl word gfind 0= ABORT" CROSS: Ghost don't exists" ghost>cfa ; Cond: ['] T ' H alit, ;Cond >CROSS : [T'] \ returns the target-cfa of a ghost, or compiles it as literal postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate \ \ threading modell 13dec92py \ modularized 14jun97jaw : fillcfa ( usedcells -- ) T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ; : (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H : (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer, : (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol, : (doprim,) ( -- ) there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) IS doprim, : (doeshandler,) ( -- ) T cfalign H compile :doesjump T 0 , H ; ' (doeshandler,) IS doeshandler, : (dodoes,) ( does-action-ghost -- ) ]comp [G'] :dodoes gexecute comp[ addr, T here H tcell - reloff 2 fillcfa ; ' (dodoes,) IS dodoes, : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, : (alit,) ( n -- ) lit, T here cell - H relon ; ' (alit,) IS alit, : (fini,) compile ;s ; ' (fini,) IS fini, [IFUNDEF] (code) Defer (code) Defer (end-code) [THEN] >TARGET : Code defempty? (THeader there resolve [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF] doprim, [THEN] depth (code) ; : Code: defempty? ghost dup there ca>native resolve swap >magic ! depth (code) ; : end-code (end-code) depth ?dup IF 1- <> ABORT" CROSS: Stack changed" ELSE true ABORT" CROSS: Stack empty" THEN ; Cond: chars ;Cond >CROSS \ tLiteral 12dec92py >TARGET Cond: \G T-\G ;Cond Cond: Literal ( n -- ) restrict? lit, ;Cond Cond: ALiteral ( n -- ) restrict? alit, ;Cond : Char ( "" -- ) bl word char+ c@ ; Cond: [Char] ( "" -- ) restrict? Char lit, ;Cond \ some special literals 27jan97jaw \ !! Known Bug: Special Literals and plug-ins work only correct \ on 16 and 32 Bit Targets and 32 Bit Hosts! Cond: MAXU restrict? tcell 1 cells u> IF compile lit tcell 0 ?DO FF T c, H LOOP ELSE $ffffffff lit, THEN ;Cond Cond: MINI restrict? tcell 1 cells u> IF compile lit bigendian IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H THEN ELSE tcell 2 = IF $8000 ELSE $80000000 THEN lit, THEN ;Cond Cond: MAXI restrict? tcell 1 cells u> IF compile lit bigendian IF 7F T c, H tcell 1 ?DO FF T c, H LOOP ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H THEN ELSE tcell 2 = IF $7fff ELSE $7fffffff THEN lit, THEN ;Cond >CROSS \ Target compiling loop 12dec92py \ ">tib trick thrown out 10may93jaw \ number? defined at the top 11may93jaw \ compiled word might leave items on stack! : tcom ( in name -- ) gfind ?dup IF 0> IF nip >exec @ execute ELSE nip gexecute THEN EXIT THEN number? dup IF 0> IF swap lit, THEN lit, drop ELSE 2drop >in ! ghost gexecute THEN ; >TARGET \ : ; DOES> 13dec92py \ ] 9may93py/jaw : ] state on BEGIN BEGIN >in @ bl word dup c@ 0= WHILE 2drop refill 0= ABORT" CROSS: End of file while target compiling" REPEAT tcom state @ 0= UNTIL ; \ by the way: defining a second interpreter (a compiler-)loop \ is not allowed if a system should be ans conform : : ( -- colon-sys ) \ Name defempty? constflag off \ don't let this flag work over colon defs \ just to go sure nothing unwanted happens >in @ skip? IF drop skip-defs EXIT THEN >in ! (THeader ;Resolve ! there ;Resolve cell+ ! docol, ]comp depth T ] H ; : :noname ( -- colon-sys ) T cfalign H there docol, 0 ;Resolve ! depth T ] H ; Cond: EXIT ( -- ) restrict? compile ;S ;Cond Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond >CROSS : LastXT ;Resolve @ 0= abort" CROSS: no definition for LastXT" ;Resolve cell+ @ ; >TARGET Cond: recurse ( -- ) Last-Ghost @ gexecute ;Cond Cond: ; ( -- ) restrict? depth ?dup IF 1- <> ABORT" CROSS: Stack changed" ELSE true ABORT" CROSS: Stack empty" THEN fini, comp[ state off ;Resolve @ IF ;Resolve @ ;Resolve cell+ @ resolve THEN ;Cond Cond: [ restrict? state off ;Cond >CROSS : !does ( does-action -- ) \ !! zusammenziehen und dodoes, machen! tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ; \ !! geht so nicht, da dodoes, ghost will! \ tlastcfa @ >tempdp dodoes, tempdp> ; >TARGET Cond: DOES> restrict? compile (does>) doeshandler, \ resolve words made by builders tdoes @ ?dup IF @ T here H resolve THEN ;Cond : DOES> switchrom doeshandler, T here H !does depth T ] H ; >CROSS \ Creation 01nov92py \ Builder 11may93jaw : Builder ( Create-xt do:-xt "name" -- ) \ builds up a builder in current vocabulary \ create-xt is executed when word is interpreted \ do:-xt is executet when the created word from builder is executed \ for do:-xt an additional entry after the normal ghost-enrys is used >in @ alias2 swap dup >in ! >r >r Make-Ghost rot swap >exec ! , r> r> >in ! also ghosts ' previous swap ! ; \ DOES> dup >exec @ execute ; : gdoes, ( ghost -- ) \ makes the codefield for a word that is built >end @ dup forward? 0= IF dup >magic @ = IF doer, EXIT THEN THEN \ compile :dodoes gexecute \ T here H tcell - reloff dodoes, ; : TCreate ( -- ) executed-ghost @ CreateFlag on create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN Theader >r dup gdoes, \ stores execution symantic in the built word >end @ >exec @ r> >exec ! ; : RTCreate ( -- ) \ creates a new word with code-field in ram executed-ghost @ CreateFlag on create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN \ make Alias (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost ) \ store poiter to code-field switchram T cfalign H there swap T ! H there tlastcfa ! dup there resolve 0 ;Resolve ! >r dup gdoes, >end @ >exec @ r> >exec ! ; : Build: ( -- [xt] [colon-sys] ) :noname postpone TCreate ; : BuildSmart: ( -- [xt] [colon-sys] ) :noname [ has-rom [IF] ] postpone RTCreate [ [ELSE] ] postpone TCreate [ [THEN] ] ; : gdoes> ( ghost -- addr flag ) executed-ghost @ state @ IF gexecute true EXIT THEN >link @ T >body H false ; \ DO: ;DO 11may93jaw \ changed to ?EXIT 10may93jaw : DO: ( -- addr [xt] [colon-sys] ) here ghostheader :noname postpone gdoes> postpone ?EXIT ; : by: ( -- addr [xt] [colon-sys] ) \ name ghost :noname postpone gdoes> postpone ?EXIT ; : ;DO ( addr [xt] [colon-sys] -- addr ) postpone ; ( S addr xt ) over >exec ! ; immediate : by ( -- addr ) \ Name ghost >end @ ; >TARGET \ Variables and Constants 05dec92py Build: ( n -- ) ; by: :docon ( ghost -- n ) T @ H ;DO Builder (Constant) Build: ( n -- ) T , H ; by (Constant) Builder Constant Build: ( n -- ) T A, H ; by (Constant) Builder AConstant Build: ( d -- ) T , , H ; DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO Builder 2Constant BuildSmart: ; by: :dovar ( ghost -- addr ) ;DO Builder Create has-rom [IF] Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; by (Constant) Builder Variable [ELSE] Build: T 0 , H ; by Create Builder Variable [THEN] has-rom [IF] Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; by (Constant) Builder AVariable [ELSE] Build: T 0 A, H ; by Create Builder AVariable [THEN] \ User variables 04may94py >CROSS Variable tup 0 tup ! Variable tudp 0 tudp ! : u, ( n -- udp ) tup @ tudp @ + T ! H tudp @ dup T cell+ H tudp ! ; : au, ( n -- udp ) tup @ tudp @ + T A! H tudp @ dup T cell+ H tudp ! ; >TARGET Build: T 0 u, , H ; by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO Builder User Build: T 0 u, , 0 u, drop H ; by User Builder 2User Build: T 0 au, , H ; by User Builder AUser BuildSmart: T , H ; by (Constant) Builder Value BuildSmart: T A, H ; by (Constant) Builder AValue BuildSmart: ( -- ) [T'] noop T A, H ; by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO Builder Defer BuildSmart: ( inter comp -- ) swap T immediate A, A, H ; DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO Builder interpret/compile: \ Sturctures 23feb95py >CROSS : nalign ( addr1 n -- addr2 ) \ addr2 is the aligned version of addr1 wrt the alignment size n 1- tuck + swap invert and ; >TARGET Build: ; by: :dofield T @ H + ;DO Builder (Field) Build: ( align1 offset1 align size "name" -- align2 offset2 ) rot dup T , H ( align1 align size offset1 ) + >r nalign r> ; by (Field) Builder Field : struct T 1 chars 0 H ; : end-struct T 2Constant H ; : cell% ( n -- size align ) T 1 cells H dup ; \ ' 2Constant Alias2 end-struct \ 0 1 T Chars H 2Constant struct 0 [IF] \ structural conditionals 17dec92py >CROSS : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; : sys? ( sys -- sys ) dup 0= ?struc ; : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; : branchoffset ( src dest -- ) - ; : >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; : TARGET \ Structural Conditionals 12dec92py Cond: BUT restrict? sys? swap ;Cond Cond: YET restrict? sys? dup ;Cond >CROSS Variable tleavings >TARGET Cond: DONE ( addr -- ) restrict? tleavings @ BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT tleavings ! drop ;Cond >CROSS : (leave T here H tleavings @ T , H tleavings ! ; >TARGET Cond: LEAVE restrict? compile branch (leave ;Cond Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond \ Structural Conditionals 12dec92py Cond: AHEAD restrict? compile branch >mark ;Cond Cond: IF restrict? compile ?branch >mark ;Cond Cond: THEN restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond Cond: BEGIN restrict? T branchto, here ( dup ." B" hex. ) H ;Cond Cond: WHILE restrict? sys? compile IF swap ;Cond Cond: AGAIN restrict? sys? compile branch r compile over compile = compile IF compile drop r> ;Cond Cond: ENDOF restrict? >r compile ELSE r> ;Cond Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond \ Structural Conditionals 12dec92py Cond: DO restrict? compile (do) T here H ;Cond Cond: ?DO restrict? compile (?do) T (leave here H ;Cond Cond: FOR restrict? compile (for) T here H ;Cond >CROSS : loop] dup TARGET Cond: LOOP restrict? sys? compile (loop) loop] ;Cond Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond Cond: NEXT restrict? sys? compile (next) loop] ;Cond [ELSE] \ structural conditionals 17dec92py >CROSS : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; : sys? ( sys -- sys ) dup 0= ?struc ; : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; : branchoffset ( src dest -- ) - ; : >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; : TARGET \ Structural Conditionals 12dec92py Cond: BUT restrict? sys? swap ;Cond Cond: YET restrict? sys? dup ;Cond >CROSS Variable tleavings >TARGET Cond: DONE ( addr -- ) restrict? tleavings @ BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT tleavings ! drop ;Cond >CROSS : (leave T here H tleavings @ T , H tleavings ! ; >TARGET Cond: LEAVE restrict? compile branch (leave ;Cond Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond \ Structural Conditionals 12dec92py Cond: AHEAD restrict? branchmark, ;Cond Cond: IF restrict? ?branchmark, ;Cond Cond: THEN restrict? sys? branchto, branchtoresolve, ;Cond Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond Cond: BEGIN restrict? branchtomark, ;Cond Cond: WHILE restrict? sys? compile IF swap ;Cond Cond: AGAIN restrict? sys? branch, ;Cond Cond: UNTIL restrict? sys? ?branch, ;Cond Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond Cond: CASE restrict? 0 ;Cond Cond: OF restrict? 1+ >r compile over compile = compile IF compile drop r> ;Cond Cond: ENDOF restrict? >r compile ELSE r> ;Cond Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond \ Structural Conditionals 12dec92py Cond: DO restrict? compile (do) T here H ;Cond Cond: ?DO restrict? compile (?do) T (leave here H ;Cond Cond: FOR restrict? compile (for) T here H ;Cond >CROSS : loop] dup TARGET Cond: LOOP restrict? sys? compile (loop) loop] ;Cond Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond Cond: NEXT restrict? sys? compile (next) loop] ;Cond [THEN] \ String words 23feb93py : ," [char] " parse T string, align H ; Cond: ." restrict? compile (.") T ," H ;Cond Cond: S" restrict? compile (S") T ," H ;Cond Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond Cond: IS T ' >body H compile ALiteral compile ! ;Cond : IS T ' >body ! H ; Cond: TO T ' >body H compile ALiteral compile ! ;Cond : TO T ' >body ! H ; Cond: defers T ' >body @ compile, H ;Cond : on T -1 swap ! H ; : off T 0 swap ! H ; \ LINKED ERR" ENV" 2ENV" 18may93jaw \ linked list primitive : linked T here over @ A, swap ! H ; : chained T linked A, H ; : err" s" ErrLink linked" evaluate T , H [char] " parse T string, align H ; : env" [char] " parse s" EnvLink linked" evaluate T string, align , H ; : 2env" [char] " parse s" EnvLink linked" evaluate here >r T string, align , , H r> dup T c@ H 80 and swap T c! H ; \ compile must be last 22feb93py Cond: compile ( -- ) restrict? \ name bl word gfind dup 0= ABORT" CROSS: Can't compile" 0> IF gexecute ELSE dup >magic @ = IF gexecute ELSE compile (compile) gexecute THEN THEN ;Cond Cond: postpone ( -- ) restrict? \ name bl word gfind dup 0= ABORT" CROSS: Can't compile" 0> IF gexecute ELSE dup >magic @ = IF gexecute ELSE compile (compile) gexecute THEN THEN ;Cond >MINIMAL also minimal \ Usefull words 13feb93py : KB 400 * ; \ define new [IFDEF] and [IFUNDEF] 20may93jaw : defined? defined? ; : needed? needed? ; : doer? doer? ; \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too : directive? bl word count [ ' target >wordlist ] aliteral search-wordlist dup IF nip THEN ; : [IFDEF] >in @ directive? swap >in ! 0= IF defined? ELSE name 2drop true THEN postpone [IF] ; : [IFUNDEF] defined? 0= postpone [IF] ; \ C: \- \+ Conditional Compiling 09jun93jaw : C: >in @ defined? 0= IF >in ! T : H ELSE drop BEGIN bl word dup c@ IF count comment? s" ;" compare 0= ?EXIT ELSE refill 0= ABORT" CROSS: Out of Input while C:" THEN AGAIN THEN ; also minimal \G doesn't skip line when bit is set in debugmask : \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ; \G interprets the line if word is not defined : \- defined? IF postpone \ THEN ; \G interprets the line if word is defined : \+ defined? 0= IF postpone \ THEN ; Cond: \- \- ;Cond Cond: \+ \+ ;Cond Cond: \D \D ;Cond : ?? bl word find IF execute ELSE drop 0 THEN ; : needed: \G defines ghost for words that we want to be compiled BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ; : [IF] postpone [IF] ; : [THEN] postpone [THEN] ; : [ELSE] postpone [ELSE] ; Cond: [IF] [IF] ;Cond Cond: [IFDEF] [IFDEF] ;Cond Cond: [IFUNDEF] [IFUNDEF] ;Cond Cond: [THEN] [THEN] ;Cond Cond: [ELSE] [ELSE] ;Cond previous \ save-cross 17mar93py >CROSS Create magic s" Gforth10" here over allot swap move char 1 bigendian + tcell + magic 7 + c! : save-cross ( "image-name" "binary-name" -- ) bl parse ." Saving to " 2dup type cr w/o bin create-file throw >r TNIL IF s" #! " r@ write-file throw bl parse r@ write-file throw s" -i" r@ write-file throw #lf r@ emit-file throw r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) ?do bl over emit-file throw loop drop magic 8 r@ write-file throw \ write magic ELSE bl parse 2drop THEN image @ there r@ write-file throw \ write image TNIL IF bit$ @ there 1- tcell>bit rshift 1+ r@ write-file throw \ write tags THEN r> close-file throw ; : save-region ( addr len -- ) bl parse w/o bin create-file throw >r swap image @ + swap r@ write-file throw r> close-file throw ; \ words that should be in minimal create s-buffer 50 chars allot >MINIMAL also minimal bigendian Constant bigendian : here there ; : >ram >ram ; : >rom >rom ; : >auto >auto ; : >tempdp >tempdp ; : tempdp> tempdp> ; : const constflag on ; : warnings name 3 = 0= twarnings ! drop ; : save-cross save-cross ; : save-region save-region ; : tdump swap >image swap dump ; also forth [IFDEF] Label : Label defempty? Label ; [THEN] [IFDEF] start-macros : start-macros defempty? start-macros ; [THEN] [IFDEF] builttag : builttag builttag ; [THEN] previous : s" [char] " parse s-buffer place s-buffer count ; \ for environment? : + + ; : 1+ 1 + ; : 2+ 2 + ; : or or ; : 1- 1- ; : - - ; : and and ; : or or ; : 2* 2* ; : * * ; : / / ; : dup dup ; : over over ; : swap swap ; : rot rot ; : drop drop ; : = = ; : 0= 0= ; : lshift lshift ; : 2/ 2/ ; : . . ; : all-words ['] false IS skip? ; : needed-words ['] needed? IS skip? ; : undef-words ['] defined? IS skip? ; : \ postpone \ ; immediate : \G T-\G ; immediate : ( postpone ( ; immediate : include bl word count included ; : require require ; : .( [char] ) parse type ; : ." [char] " parse type ; : cr cr ; : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation only forth also minimal definitions \ cross-compiler words : decimal decimal ; : hex hex ; : tudp T tudp H ; : tup T tup H ; : doc-off false T to-doc H ! ; : doc-on true T to-doc H ! ; [IFDEF] dbg : dbg dbg ; [THEN] minimal \ for debugging... : order order ; : hwords words ; : words also ghosts words previous ; : .s .s ; : bye bye ; \ turnkey direction : H forth ; immediate : T minimal ; immediate : G ghosts ; immediate : turnkey 0 set-order also Target definitions also Minimal also ; \ these ones are pefered: : lock turnkey ; : unlock forth also cross ; : [[ also unlock ; : ]] previous previous ; unlock definitions also minimal : lock lock ; lock