--- gforth/cross.fs 1994/09/09 16:27:17 1.12 +++ gforth/cross.fs 2000/05/04 09:31:16 1.84 @@ -1,66 +1,65 @@ \ CROSS.FS The Cross-Compiler 06oct92py -\ $Id: cross.fs,v 1.12 1994/09/09 16:27:17 anton Exp $ \ Idea and implementation: Bernd Paysan (py) -\ Copyright 1992 by the ANSI figForth Development Group -\ 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 +\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. -\ include other.fs \ ansforth extentions for cross +\ This file is part of Gforth. -: comment? ( c-addr u -- c-addr u ) - 2dup s" (" compare 0= - IF postpone ( - ELSE 2dup s" \" compare 0= IF postpone \ THEN - THEN ; +\ 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. + +0 +[IF] + +ToDo: +Crossdoc destination ./doc/crossdoc.fd makes no sense when +cross.fs is uses seperately. jaw +Do we need this char translation with >address and in branchoffset? +(>body also affected) jaw +Clean up mark> and >resolve stuff jaw -decimal +[THEN] -\ Begin CROSS COMPILER: +hex -\ GhostNames 9may93jaw -\ second name source to search trough list +\ debugging for compiling -VARIABLE GhostNames -0 GhostNames ! -: GhostName ( -- addr ) - here GhostNames @ , GhostNames ! here 0 , - name count -\ 2dup type space - dup c, here over chars allot swap move align ; +\ print stack at each colon definition +\ : : save-input cr bl word count type restore-input throw .s : ; + +\ print stack at each created word +\ : create save-input cr bl word count type restore-input throw .s create ; -hex +\ \ ------------- Setup Vocabularies + +\ Remark: Vocabulary is not ANS, but it should work... Vocabulary Cross Vocabulary Target Vocabulary Ghosts -VOCABULARY Minimal +Vocabulary Minimal only Forth also Target also also definitions Forth -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : H previous Forth also Cross ; immediate forth definitions -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : >cross also Cross definitions previous ; @@ -71,130 +70,587 @@ H >CROSS -\ Variables 06oct92py +\ find out whether we are compiling with gforth --1 Constant NIL -Variable image -Variable tlast NIL tlast ! \ Last name field -Variable tlastcfa \ Last code field -Variable tdoes \ Resolve does> calls -Variable bit$ -Variable tdp -: there tdp @ ; +: defined? bl word find nip ; +defined? emit-file defined? toupper and \ drop 0 +[IF] +\ use this in a gforth system +: \GFORTH ; immediate +: \ANSI postpone \ ; immediate +[ELSE] +: \GFORTH postpone \ ; immediate +: \ANSI ; immediate +[THEN] -\ Parameter for target systems 06oct92py +\ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate +\ANSI : [IFDEF] defined? postpone [IF] ; immediate +0 \ANSI drop 1 +[IF] +: \G postpone \ ; immediate +: rdrop postpone r> postpone drop ; immediate +: name bl word count ; +: bounds over + swap ; +: scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ; +: linked here over @ , swap ! ; +: alias create , DOES> @ EXECUTE ; +: defer ['] noop alias ; +: is state @ + IF ' >body postpone literal postpone ! + ELSE ' >body ! THEN ; immediate +: 0>= 0< 0= ; +: d<> rot <> -rot <> or ; +: toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ; +Variable ebuf +: emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ; +0a Constant #lf +0d Constant #cr -include-file +[IFUNDEF] Warnings Variable Warnings [THEN] ->TARGET +\ \ Number parsing 23feb93py -\ Byte ordering and cell size 06oct92py +\ number? number 23feb93py -: cell+ cell + ; -: cells cell<< lshift ; -: chars ; -: floats float * ; - ->CROSS -: cell/ cell<< rshift ; ->TARGET -20 CONSTANT bl --1 Constant NIL --2 Constant :docol --3 Constant :docon --4 Constant :dovar --5 Constant :douser --6 Constant :dodefer --7 Constant :dodoes --8 Constant :doesjump +Variable dpl ->CROSS +hex +Create bases 10 , 2 , A , 100 , +\ 16 2 10 character + +\ !! protect BASE saving wrapper against exceptions +: getbase ( addr u -- addr' u' ) + over c@ [char] $ - dup 4 u< + IF + cells bases + @ base ! 1 /string + ELSE + drop + THEN ; + +: sign? ( addr u -- addr u flag ) + over c@ [char] - = dup >r + IF + 1 /string + THEN + r> ; + +: s>unumber? ( addr u -- ud flag ) + over [char] ' = + IF \ a ' alone is rather unusual :-) + drop char+ c@ 0 true EXIT + THEN + base @ >r dpl on getbase + 0. 2swap + BEGIN ( d addr len ) + dup >r >number dup + WHILE \ there are characters left + dup r> - + WHILE \ the last >number parsed something + dup 1- dpl ! over c@ [char] . = + WHILE \ the current char is '.' + 1 /string + REPEAT THEN \ there are unparseable characters left + 2drop false + ELSE + rdrop 2drop true + THEN + r> base ! ; + +\ ouch, this is complicated; there must be a simpler way - anton +: s>number? ( addr len -- d f ) + \ converts string addr len into d, flag indicates success + sign? >r + s>unumber? + 0= IF + rdrop false + ELSE \ no characters left, all ok + r> + IF + dnegate + THEN + true + THEN ; + +: s>number ( addr len -- d ) + \ don't use this, there is no way to tell success + s>number? drop ; + +: snumber? ( c-addr u -- 0 / n -1 / d 0> ) + s>number? 0= + IF + 2drop false EXIT + THEN + dpl @ dup 0< IF + nip + ELSE + 1+ + THEN ; + +: number? ( string -- string 0 / n -1 / d 0> ) + dup >r count snumber? dup if + rdrop + else + r> swap + then ; + +: number ( string -- d ) + number? ?dup 0= abort" ?" 0< + IF + s>d + THEN ; -bigendian 0 pad ! -1 pad c! pad @ 0< -= [IF] : bswap ; immediate -[ELSE] : bswap ( big / little -- little / big ) 0 - cell 1- FOR bits/byte lshift over - [ 1 bits/byte lshift 1- ] Literal and or - swap bits/byte rshift swap NEXT nip ; -[THEN] - -\ Memory initialisation 05dec92py -\ Fixed bug in else part 11may93jaw - -[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 +hex \ the defualt base for the cross-compiler is hex !! +\ Warnings off ->MINIMAL -: makekernal ( targetsize -- targetsize ) - bit$ over 1- cell>bit rshift 1+ initmem - image over initmem tdp off ; +\ words that are generaly useful ->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@ ; +: KB 400 * ; +: >wordlist ( vocabulary-xt -- wordlist-struct ) + also execute get-order swap >r 1- set-order r> ; -: >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 ; +: umax 2dup u< IF swap THEN drop ; +: umin 2dup u> IF swap THEN drop ; -\ Target memory access 06oct92py +: string, ( c-addr u -- ) + \ puts down string as cstring + dup c, here swap chars dup allot move ; + +: ," [char] " parse string, ; + +: SetValue ( n -- ) +\G Same behaviour as "Value" if the is not defined +\G Same behaviour as "to" if is defined +\G SetValue searches in the current vocabulary + save-input bl word >r restore-input throw r> count + get-current search-wordlist + IF drop >r + \ we have to set current to be topmost context wordlist + get-order get-order get-current swap 1+ set-order + r> ['] to execute + set-order + ELSE Value THEN ; + +: DefaultValue ( n -- ) +\G Same behaviour as "Value" if the is not defined +\G DefaultValue searches in the current vocabulary + save-input bl word >r restore-input throw r> count + get-current search-wordlist + IF bl word drop 2drop ELSE Value THEN ; -: align+ ( taddr -- rest ) - cell tuck 1- and - [ cell 1- ] Literal and ; +hex ->TARGET -: aligned ( taddr -- ta-addr ) dup align+ + ; -\ assumes cell alignment granularity (as GNU C) +\ 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: + +\ debugging + +0 [IF] + +This implements debugflags for the cross compiler and the compiled +images. It works identical to the has-flags in the environment. +The debugflags are defined in a vocabluary. If the word exists and +its value is true, the flag is switched on. + +[THEN] >CROSS -: >image ( taddr -- absaddr ) image @ + ; ->TARGET -: @ ( taddr -- w ) >image @ bswap ; -: ! ( w taddr -- ) >r bswap r> >image ! ; -: 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 +Vocabulary debugflags \ debug flags for cross +also debugflags get-order over +Constant debugflags-wl +set-order previous + +: DebugFlag + get-current >r debugflags-wl set-current + SetValue + r> set-current ; + +: Debug? ( adr u -- flag ) +\G return true if debug flag is defined or switched on + debugflags-wl search-wordlist + IF EXECUTE + ELSE false THEN ; + +: D? ( -- flag ) +\G return true if debug flag is defined or switched on +\G while compiling we do not return the current value but + bl word count debug? ; + +: [d?] +\G compile the value-xt so the debug flag can be switched +\G the flag must exist! + bl word count debugflags-wl search-wordlist + IF compile, + ELSE -1 ABORT" unknown debug flag" + \ POSTPONE false + THEN ; immediate -: here ( -- there ) there ; -: allot ( n -- ) tdp +! ; -: , ( w -- ) T here H cell T allot ! H ; -: c, ( char -- ) T here 1 allot c! H ; -: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; +\ \ -------------------- source file + +decimal + +Variable cross-file-list +0 cross-file-list ! +Variable target-file-list +0 target-file-list ! +Variable host-file-list +0 host-file-list ! + +cross-file-list Value file-list +0 Value source-desc + +\ file loading + +: >fl-id 1 cells + ; +: >fl-name 2 cells + ; + +Variable filelist 0 filelist ! +Create NoFile ," #load-file#" + +: loadfile ( -- adr ) + source-desc ?dup IF >fl-name ELSE NoFile THEN ; + +: sourcefilename ( -- adr len ) + loadfile count ; + +\ANSI : sourceline# 0 ; + +\ \ -------------------- path handling from kernel/paths.fs + +\ paths.fs path file handling 03may97jaw + +\ -Changing the search-path: +\ fpath+ adds a directory to the searchpath +\ fpath= | makes complete now searchpath +\ seperator is | +\ .fpath displays the search path +\ remark I: +\ a ./ in the beginning of filename is expanded to the directory the +\ current file comes from. ./ can also be included in the search-path! +\ ~+/ loads from the current working directory + +\ remark II: +\ if there is no sufficient space for the search path increase it! + + +\ -Creating custom paths: + +\ It is possible to use the search mechanism on yourself. + +\ Make a buffer for the path: +\ create mypath 100 chars , \ maximum length (is checked) +\ 0 , \ real len +\ 100 chars allot \ space for path +\ use the same functions as above with: +\ mypath path+ +\ mypath path= +\ mypath .path + +\ do a open with the search path: +\ open-path-file ( adr len path -- fd adr len ior ) +\ the file is opened read-only; if the file is not found an error is generated -: A! dup relon T ! H ; -: A, ( w -- ) T here H relon T , H ; +\ questions to: wilke@jwdt.com + +[IFUNDEF] +place +: +place ( adr len adr ) + 2dup >r >r + dup c@ char+ + swap move + r> r> dup c@ rot + swap c! ; +[THEN] + +[IFUNDEF] place +: place ( c-addr1 u c-addr2 ) + 2dup c! char+ swap move ; +[THEN] + +\ if we have path handling, use this and the setup of it +[IFUNDEF] open-fpath-file + +create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic +sourcepath value fpath + +: also-path ( adr len path^ -- ) + >r + \ len check + r@ cell+ @ over + r@ @ u> ABORT" path buffer too small!" + \ copy into + tuck r@ cell+ dup @ cell+ + swap cmove + \ make delimiter + 0 r@ cell+ dup @ cell+ + 2 pick + c! 1 + r> cell+ +! + ; + +: only-path ( adr len path^ -- ) + dup 0 swap cell+ ! also-path ; + +: path+ ( path-addr "dir" -- ) \ gforth + \G Add the directory @var{dir} to the search path @var{path-addr}. + name rot also-path ; + +: fpath+ ( "dir" ) \ gforth + \G Add directory @var{dir} to the Forth search path. + fpath path+ ; + +: path= ( path-addr "dir1|dir2|dir3" ) \ gforth + \G Make a complete new search path; the path separator is |. + name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP + rot only-path ; + +: fpath= ( "dir1|dir2|dir3" ) \ gforth + \G Make a complete new Forth search path; the path separator is |. + fpath path= ; + +: path>counted cell+ dup cell+ swap @ ; + +: next-path ( adr len -- adr2 len2 ) + 2dup 0 scan + dup 0= IF 2drop 0 -rot 0 -rot EXIT THEN + >r 1+ -rot r@ 1- -rot + r> - ; + +: previous-path ( path^ -- ) + dup path>counted + BEGIN tuck dup WHILE repeat ; + +: .path ( path-addr -- ) \ gforth + \G Display the contents of the search path @var{path-addr}. + path>counted + BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; + +: .fpath ( -- ) \ gforth + \G Display the contents of the Forth search path. + fpath .path ; + +: absolut-path? ( addr u -- flag ) \ gforth + \G A path is absolute if it starts with a / or a ~ (~ expansion), + \G or if it is in the form ./*, extended regexp: ^[/~]|./, or if + \G it has a colon as second character ("C:..."). Paths simply + \G containing a / are not absolute! + 2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/.... + over c@ [char] / = >r + over c@ [char] ~ = >r + \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic + 2 min S" ./" compare 0= + r> r> r> or or or ; + +Create ofile 0 c, 255 chars allot +Create tfile 0 c, 255 chars allot + +: pathsep? dup [char] / = swap [char] \ = or ; + +: need/ ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ; + +: extractpath ( adr len -- adr len2 ) + BEGIN dup WHILE 1- + 2dup + c@ pathsep? IF EXIT THEN + REPEAT ; + +: remove~+ ( -- ) + ofile count 3 min s" ~+/" compare 0= + IF + ofile count 3 /string ofile place + THEN ; + +: expandtopic ( -- ) \ stack effect correct? - anton + \ expands "./" into an absolute name + ofile count 2 min s" ./" compare 0= + IF + ofile count 1 /string tfile place + 0 ofile c! sourcefilename extractpath ofile place + ofile c@ IF need/ THEN + tfile count over c@ pathsep? IF 1 /string THEN + ofile +place + THEN ; + +: compact.. ( adr len -- adr2 len2 ) +\ deletes phrases like "xy/.." out of our directory name 2dec97jaw + over >r -1 >r + BEGIN dup WHILE + over c@ pathsep? + IF r@ -1 = + IF r> drop dup >r + ELSE 2dup 1 /string + 3 min s" ../" compare + 0= + IF r@ over - ( diff ) + 2 pick swap - ( dest-adr ) + >r 3 /string r> swap 2dup >r >r + move r> r> + ELSE r> drop dup >r + THEN + THEN + THEN + 1 /string + REPEAT + r> drop + drop r> tuck - ; + +: reworkdir ( -- ) + remove~+ + ofile count compact.. + nip ofile c! ; + +: open-ofile ( -- fid ior ) + \G opens the file whose name is in ofile + expandtopic reworkdir + ofile count r/o open-file ; + +: check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 ) + 0 ofile ! >r >r ofile place need/ + r> r> ofile +place + open-ofile ; + +: open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth + \G Look in path @var{path-addr} for the file specified by @var{addr1 u1}. + \G If found, the resulting path and an open file descriptor + \G are returned. If the file is not found, @var{ior} is non-zero. + >r + 2dup absolut-path? + IF rdrop + ofile place open-ofile + dup 0= IF >r ofile count r> THEN EXIT + ELSE r> path>counted + BEGIN next-path dup + WHILE 5 pick 5 pick check-path + 0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN + REPEAT + 2drop 2drop 2drop -38 + THEN ; + +: open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth + \G Look in the Forth search path for the file specified by @var{addr1 u1}. + \G If found, the resulting path and an open file descriptor + \G are returned. If the file is not found, @var{ior} is non-zero. + fpath open-path-file ; + +fpath= ~+ + +[THEN] + +\ \ -------------------- include require 13may99jaw >CROSS -\ threading modell 13dec92py +: add-included-file ( adr len -- adr ) + dup >fl-name char+ allocate throw >r + file-list @ r@ ! r@ file-list ! + r@ >fl-name place r> ; + +: included? ( c-addr u -- f ) + file-list + BEGIN @ dup + WHILE >r 2dup r@ >fl-name count compare 0= + IF rdrop 2drop true EXIT THEN + r> + REPEAT + 2drop drop false ; + +false DebugFlag showincludedfiles + +: included1 ( fd adr u -- ) +\ include file adr u / fd +\ we don't use fd with include-file, because the forth system +\ doesn't know the name of the file to get a nice error report + [d?] showincludedfiles + IF cr ." Including: " 2dup type ." ..." THEN + rot close-file throw + source-desc >r + add-included-file to source-desc + sourcefilename + ['] included catch + r> to source-desc + throw ; + +: included ( adr len -- ) + cross-file-list to file-list + open-fpath-file throw + included1 ; + +: required ( adr len -- ) + cross-file-list to file-list + open-fpath-file throw \ 2dup cr ." R:" type + 2dup included? + IF 2drop close-file throw + ELSE included1 + THEN ; -\ generic threading modell -: docol, ( -- ) :docol T A, 0 , H ; +: include bl word count included ; + +: require bl word count required ; + +0 [IF] + +also forth definitions previous + +: included ( adr len -- ) included ; + +: required ( adr len -- ) required ; + +: include include ; + +: require require ; + +[THEN] ->TARGET -: >body ( cfa -- pfa ) T cell+ cell+ H ; >CROSS +hex + +\ \ -------------------- 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 -: dodoes, ( -- ) T :doesjump A, 0 , H ; +previous >CROSS + +: .dec + base @ decimal swap . base ! ; + +: .sourcepos + cr sourcefilename type ." :" + sourceline# .dec ; + +: 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 ) + align here GhostNames @ , GhostNames ! here 0 , + bl word count + \ 2dup type space + string, \ !! cfalign ? + align ; \ Ghost Builder 06oct92py @@ -205,78 +661,816 @@ VARIABLE VocTemp : previous VocTemp @ set-current ; +hex 4711 Constant 4712 Constant -4713 Constant +4713 Constant 4714 Constant +4715 Constant \ iForth makes only immediate directly after create \ make atonce trick! ? Variable atonce atonce off -: NoExec true ABORT" CROSS: Don't execute ghost" ; +: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ; : GhostHeader , 0 , ['] NoExec , ; -: >magic ; : >link cell+ ; : >exec cell+ cell+ ; -: >end 3 cells + ; +: >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 -Variable last-ghost : Make-Ghost ( "name" -- ghost ) >in @ GhostName swap >in ! - DOES> dup last-ghost ! >exec @ execute ; + 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 -\ !! wouldn't it be simpler to just use search-wordlist ? ae - dup count [ ' ghosts >body ] ALiteral search-wordlist -\ >r get-order 0 set-order also ghosts r> find >r >r - >r r@ IF >body nip THEN r> ; -\ set-order r> r@ IF >body THEN r> ; + dup count [ ' ghosts >wordlist ] Literal 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 @ name gfind IF Already on nip EXIT THEN + >in @ bl word gfind IF atonce off 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" + s" ?!?!?!" + THEN ; + +: .ghost ( ghost -- ) >ghostname type ; + +\ ' >ghostname ALIAS @name + +: forward? ( ghost -- flag ) + >magic @ = ; + +: undefined? ( ghost -- flag ) + >magic @ dup = swap = or ; + +\ 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 :dovar drop +ghost over ghost = ghost drop 2drop drop +ghost - drop +ghost 2drop drop +ghost 2dup 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? ( adr len -- [ x ] true | false ) + target-environment search-wordlist + IF execute true ELSE false THEN ; + +: e? bl word count T environment? H 0= ABORT" environment variable not defined!" ; + +: has? bl word count T environment? H + IF \ environment variable is present, return its value + ELSE \ environment variable is not present, return false + false \ debug true ABORT" arg" + THEN ; + +: $has? T environment? H IF ELSE false THEN ; + +>ENVIRON get-order get-current swap 1+ set-order +true SetValue compiler +true SetValue cross +true SetValue standard-threading +>TARGET previous + +0 +[IFDEF] mach-file mach-file count 1 [THEN] +[IFDEF] machine-file machine-file 1 [THEN] +[IF] included hex drop +[ELSE] cr ." No machine description!" ABORT +[THEN] + +>ENVIRON + +T has? ec H +[IF] +false DefaultValue relocate +false DefaultValue file +false DefaultValue OS +false DefaultValue prims +false DefaultValue floating +false DefaultValue glocals +false DefaultValue dcomps +false DefaultValue hash +false DefaultValue xconds +false DefaultValue header +[THEN] + +true DefaultValue interpreter +true DefaultValue ITC +false DefaultValue rom +true DefaultValue standardthreading + +>TARGET +s" relocate" T environment? H +[IF] SetValue NIL +[ELSE] >ENVIRON T NIL H SetValue relocate +[THEN] + +>CROSS + +\ \ Create additional parameters 19jan95py + +\ currently cross only works for host machines with address-unit-bits +\ eual to 8 because of s! and sc! +\ but I start to query the environment just to modularize a little bit + +: check-address-unit-bits ( -- ) +\ s" ADDRESS-UNIT-BITS" environment? +\ IF 8 <> ELSE true THEN +\ ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!" + +\ shit, this doesn't work because environment? is only defined for +\ gforth.fi and not kernl???.fi + ; + +check-address-unit-bits +8 Constant bits/byte \ we define: byte is address-unit + +1 bits/byte lshift Constant maxbyte +\ this sets byte size for the target machine, (probably right guess) jaw + +T +NIL Constant TNIL +cell Constant tcell +cell<< Constant tcell<< +cell>bit Constant tcell>bit +bits/char Constant tbits/char +bits/char H bits/byte T / + Constant tchar +float Constant tfloat +1 bits/char lshift Constant tmaxchar +[IFUNDEF] bits/byte +8 Constant tbits/byte +[ELSE] +bits/byte Constant tbits/byte +[THEN] +H +tbits/char bits/byte / Constant tbyte + + +\ 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 ! + +: target>bitmask-size ( u1 -- u2 ) + 1- tcell>bit rshift 1+ ; + +: allocatetarget ( size --- adr ) + dup allocate ABORT" CROSS: No memory for target" + swap over swap erase ; + +\ \ 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 ! + + +: >rname 6 cells + ; +: >rbm 5 cells + ; +: >rmem 4 cells + ; +: >rlink 3 cells + ; +: >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 0 , 0 , bl word count string, + ELSE \ store new parameters in region + bl word drop + >body >r r@ last-defined-region ! + r@ >rlen ! dup r@ >rstart ! r> >rdp ! + THEN ; + +: borders ( region -- startaddr endaddr ) \G returns lower and upper region border + dup >rstart @ swap >rlen @ over + ; + +: extent ( region -- startaddr len ) \G returns the really used area + dup >rstart @ swap >rdp @ over - ; + +: area ( region -- startaddr totallen ) \G returns the total area + dup >rstart @ swap >rlen @ ; + +: mirrored \G mark a region as mirrored + mirrored-link + align linked last-defined-region @ , ; + +: .addr ( u -- ) +\G prints a 16 or 32 Bit nice hex value + base @ >r hex + tcell 2 u> + IF s>d <# # # # # [char] . 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 + 0 >rlink - >r + r@ >rname count tuck type + 12 swap - 0 max spaces space + ." Start: " r@ >rstart @ dup .addr space + ." End: " r@ >rlen @ + .addr space + ." DP: " r> >rdp @ .addr + REPEAT drop + s" rom" T $has? H 0= ?EXIT + cr ." Mirrored:" + mirrored-link @ + BEGIN dup + WHILE space dup cell+ @ >rname 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 + +T has? rom H +[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" T $has? H + IF \ check for ram and rom... + \ address-space area nip 0<> + ram-dictionary area nip 0<> + rom-dictionary area nip 0<> + 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 + nip 0= + ABORT" CROSS: define at least address-space or dictionary!!" + + \ allocate target for each region + region-link + BEGIN @ dup + WHILE dup + 0 >rlink - >r + r@ >rlen @ + IF \ allocate mem + r@ >rlen @ dup + + allocatetarget dup image ! + r@ >rmem ! + + target>bitmask-size allocatetarget + dup bit$ ! + r> >rbm ! + + ELSE r> drop THEN + REPEAT drop ; + +\ MakeKernal 22feb99jaw + +: makekernel ( targetsize -- targetsize ) + dup dictionary >rlen ! setup-target ; + +>MINIMAL +: makekernel makekernel ; +>CROSS + +\ \ 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 + +: activate ( region -- ) +\G next code goes to this region + >rdp to tdp ; + +: (switchram) + fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT + ram-dictionary activate ; + +: switchram + constflag @ + IF constflag off ELSE (switchram) THEN ; + +: switchrom + fixed @ ?EXIT rom-dictionary activate ; + +: >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 goes 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 tchar * ; +: char+ tchar + ; +: 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 ; + : Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1- + DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; + : Sc@ ( addr -- n ) >r 0 0 r> tchar 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 ; + : Sc! ( n addr -- ) >r s>d r> tchar bounds + DO maxbyte ud/mod rot I c! LOOP 2drop ; + : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1- + DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; +[THEN] + +: taddr>region ( taddr -- region | 0 ) +\G finds for a target-address the correct region +\G returns 0 if taddr is not in range of a target memory region + region-link + BEGIN @ dup + WHILE dup >r + 0 >rlink - >r + r@ >rlen @ + IF dup r@ borders within + IF r> r> drop nip EXIT THEN + THEN + r> drop + r> + REPEAT + 2drop 0 ; + +: (>regionimage) ( taddr -- 'taddr ) + dup + \ find region we want to address + taddr>region dup 0= ABORT" Address out of range!" + >r + \ calculate offset in region + r@ >rstart @ - + \ add regions real address in our memory + r> >rmem @ + ; + +\ 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 -- ) + [ [IFDEF] fd-relocation-table ] + s" +" fd-relocation-table write-file throw + dup s>d <# #s #> fd-relocation-table write-line throw + [ [THEN] ] + bit$ @ swap cell/ +bit ; + +: (reloff) ( taddr -- ) + [ [IFDEF] fd-relocation-table ] + s" -" fd-relocation-table write-file throw + dup s>d <# #s #> fd-relocation-table write-line throw + [ [THEN] ] + bit$ @ swap cell/ -bit ; + +: (>image) ( taddr -- absaddr ) image @ + ; + +DEFER >image +DEFER relon +DEFER reloff +DEFER correcter + +T has? relocate H +[IF] +' (relon) IS relon +' (reloff) IS reloff +' (>image) IS >image +[ELSE] +' drop IS relon +' drop IS reloff +' (>regionimage) IS >image +[THEN] + +\ 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+ + ; + +: @ ( taddr -- w ) >image S@ ; +: ! ( w taddr -- ) >image S! ; +: c@ ( taddr -- char ) >image Sc@ ; +: c! ( char taddr -- ) >image Sc! ; +: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; +: 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ; + +\ Target compilation primitives 06oct92py +\ included A! 16may93jaw + +: here ( -- there ) there ; +: allot ( n -- ) tdp +! ; +: , ( w -- ) T here H tcell T allot ! H ; +: c, ( char -- ) T here H tchar T allot c! H ; +: align ( -- ) T here H align+ 0 ?DO bl T c, H tchar +LOOP ; +: cfalign ( -- ) + T here H cfalign+ 0 ?DO bl T c, H tchar +LOOP ; + +: >address dup 0>= IF tbyte / THEN ; \ ?? jaw +: A! swap >address swap dup relon T ! H ; +: A, ( w -- ) >address T here H relon T , H ; + +>CROSS + +: tcmove ( source dest len -- ) +\G cmove in target memory + tchar * bounds + ?DO dup T c@ H I T c! H 1+ + tchar +LOOP drop ; + +\ \ Load Assembler + +>TARGET +H also Forth definitions + +: X bl word count [ ' target >wordlist ] Literal search-wordlist + IF state @ IF compile, + ELSE execute THEN + ELSE -1 ABORT" Cross: access method not supported!" + THEN ; immediate + +[IFDEF] asm-include asm-include [THEN] hex + +previous +>CROSS H + +\ \ -------------------- Compiler Plug Ins 01aug97jaw + +\ Compiler States + +Variable comp-state +0 Constant interpreting +1 Constant compiling +2 Constant resolving +3 Constant assembling + +Defer lit, ( n -- ) +Defer alit, ( n -- ) + +Defer branch, ( target-addr -- ) \ compiles a branch +Defer ?branch, ( target-addr -- ) \ compiles a ?branch +Defer branchmark, ( -- branch-addr ) \ reserves room for a branch +Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch +Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch +Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) +Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark +Defer branchfrom, ( -- ) \ ?! +Defer branchtomark, ( -- target-addr ) \ marks a branch destination + +Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position +Defer colonmark, ( -- addr ) \ marks a colon call +Defer colon-resolve ( tcfa addr -- ) + +Defer addr-resolve ( target-addr addr -- ) +Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) + +Defer do, ( -- do-token ) +Defer ?do, ( -- ?do-token ) +Defer for, ( -- for-token ) +Defer loop, ( do-token / ?do-token -- ) +Defer +loop, ( do-token / ?do-token -- ) +Defer next, ( for-token ) + +[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, \ compiles start of a primitive +DEFER docol, \ compiles start of a colon definition +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 +: (dr) ( ghost res-pnt target-addr addr ) + >tempdp drop over + dup >magic @ = + IF doer, + ELSE dodoes, + THEN + tempdp> ; ' (dr) IS doer-resolve + +: (cm) ( -- addr ) + T here align H + -1 colon, ; ' (cm) IS colonmark, + +>TARGET +: compile, colon, ; +>CROSS + +\ resolve structure + +: >next ; \ link to next field +: >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer +: >taddr cell+ cell+ ; +: >ghost 3 cells + ; +: >file 4 cells + ; +: >line 5 cells + ; + +: (refered) ( ghost addr tag -- ) +\G creates a reference to ghost at address taddr + rot >r here r@ >link @ , r> >link ! + ( taddr tag ) , + ( taddr ) , + last-header-ghost @ , + loadfile , + sourceline# , + ; + +: refered ( ghost tag -- ) +\G creates a resolve structure + T here aligned H swap (refered) + ; + +: killref ( addr ghost -- ) +\G kills a forward reference to ghost at position addr +\G this is used to eleminate a :dovar refence after making a DOES> + dup >magic @ <> IF 2drop EXIT THEN + swap >r >link + BEGIN dup @ dup ( addr last this ) + WHILE dup >taddr @ r@ = + IF @ over ! + ELSE nip THEN + REPEAT rdrop 2drop + ; + +Defer resolve-warning + +: reswarn-test ( ghost res-struct -- ghost res-struct ) + over cr ." Resolving " .ghost dup ." in " >ghost @ .ghost ; + +: reswarn-forward ( ghost res-struct -- ghost res-struct ) + over warnhead .ghost dup ." is referenced in " + >ghost @ .ghost ; + +\ ' reswarn-test IS resolve-warning + \ resolve 14oct92py -: resolve-loop ( ghost tcfa -- ghost tcfa ) - >r dup >link @ - BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ; + : resolve-loop ( ghost resolve-list tcfa -- ) + >r + BEGIN dup WHILE +\ dup >tag @ 2 = IF reswarn-forward THEN + resolve-warning + r@ over >taddr @ + 2 pick >tag @ + CASE 0 OF colon-resolve ENDOF + 1 OF addr-resolve ENDOF + 2 OF doer-resolve ENDOF + ENDCASE + @ \ next list element + REPEAT 2drop rdrop + ; + +\ : 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 - nip 2 cells + count cr ." CROSS: Exists: " type 4 spaces - swap cell+ ! - ELSE true ABORT" CROSS: Ghostnames inconsistent" + 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 -- ) - over >magic @ <> IF exists EXIT THEN - resolve-loop over >link ! swap >magic ! ; +\G resolve referencies to ghost with tcfa + \ is ghost resolved?, second resolve means another definition with the + \ same name + over undefined? 0= IF exists EXIT THEN + \ get linked-list + swap >r r@ >link @ swap \ ( list tcfa R: ghost ) + \ mark ghost as resolved + dup r@ >link ! r@ >magic ! + \ loop through forward referencies + r> -rot + comp-state @ >r Resolving comp-state ! + resolve-loop + r> comp-state ! + + ['] noop IS resolve-warning + ; \ gexecute ghost, 01nov92py -: do-forward ( ghost -- ) - >link dup @ there rot ! T A, H ; -: do-resolve ( ghost -- ) - >link @ T A, H ; - -: gexecute ( ghost -- ) dup @ - = IF do-forward ELSE do-resolve THEN ; -: ghost, ghost gexecute ; +: is-forward ( ghost -- ) + colonmark, 0 (refered) ; \ compile space for call + +: 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 @@ -284,14 +1478,28 @@ variable ResolveFlag \ ?touched 11may93jaw -: ?touched ( ghost -- flag ) dup >magic @ = swap >link @ +: ?touched ( ghost -- flag ) dup forward? swap >link @ 0 <> and ; +: .forwarddefs ( ghost -- ) + ." appeared in:" + >link + BEGIN @ dup + WHILE cr 5 spaces + dup >ghost @ .ghost + ." file " dup >file @ ?dup IF count type ELSE ." CON" THEN + ." line " dup >line @ .dec + REPEAT + drop ; + : ?resolved ( ghostname -- ) dup cell+ @ ?touched - IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ; + IF dup + cell+ cell+ count cr type ResolveFlag on + cell+ @ .forwarddefs + ELSE drop + THEN ; ->MINIMAL : .unresolved ( -- ) ResolveFlag off cr ." Unresolved: " Ghostnames @@ -299,12 +1507,21 @@ variable ResolveFlag WHILE dup ?resolved REPEAT drop ResolveFlag @ IF - abort" Unresolved words!" + -1 abort" Unresolved words!" ELSE ." Nothing!" THEN cr ; +: .stats + base @ >r decimal + cr ." named Headers: " headers-named @ . + r> base ! ; + +>MINIMAL + +: .unresolved .unresolved ; + >CROSS \ Header states 12dec92py @@ -313,50 +1530,208 @@ variable ResolveFlag VARIABLE ^imm >TARGET -: immediate 20 flag! - ^imm @ @ dup = ?EXIT +: immediate 40 flag! + ^imm @ @ dup = IF drop EXIT THEN <> ABORT" CROSS: Cannot immediate a unresolved word" ^imm @ ! ; -: restrict 40 flag! ; ->CROSS - -\ ALIAS2 ansforth conform alias 9may93jaw +: restrict 20 flag! ; -: ALIAS2 create here 0 , DOES> @ execute ; -\ usage: -\ ' alias2 bla ! +: isdoer +\G define a forth word as doer, this makes obviously only sence on +\G forth processors such as the PSC1000 + last-header-ghost @ >magic ! ; +>CROSS \ Target Header Creation 01nov92py +>TARGET : string, ( addr count -- ) - dup T c, H bounds DO I c@ T c, H LOOP ; -: name, ( "name" -- ) name count string, T align H ; + 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 -VARIABLE CreateFlag CreateFlag off +s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id +\ contains the file-id of the documentation file -: (Theader ( "name" -- ghost ) T align H view, - tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! - >in @ name, >in ! T here H tlastcfa ! - 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 >magic ^imm ! \ a pointer for immediate - Already @ IF dup >end tdoes ! - ELSE 0 tdoes ! THEN - 80 flag! ; +: 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 ( -- ) + sourcefilename 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? + +: skipdef ( -- ) +\G skip definition of an undefined word in undef-words and +\G all-words mode + ghost dup forward? + IF >magic swap ! + ELSE drop THEN ; + +: tdefined? ( -- flag ) \ name + ghost undefined? 0= ; + +: defined2? ( -- flag ) \ name +\G return true for anything else than forward, even for +\G that's what we want + ghost forward? 0= ; + +: forced? ( -- flag ) \ name +\G return ture if it is a foreced skip with defskip + ghost >magic @ = ; + +: 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 undefined? + 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 NoHeaderFlag +NoHeaderFlag off + +: 0.r ( n1 n2 -- ) + base @ >r hex + 0 swap <# 0 ?DO # LOOP #> type + r> base ! ; + +: .sym ( adr len -- ) +\G escapes / and \ to produce sed output + bounds + DO I c@ dup + CASE [char] / OF drop ." \/" ENDOF + [char] \ 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 + \ build header in target + NoHeaderFlag @ + IF NoHeaderFlag off + ELSE + T align H view, + tlast @ dup 0> IF tcell - THEN T A, H there tlast ! + 1 headers-named +! \ Statistic + >in @ T name, H >in ! + THEN + T cfalign here H tlastcfa ! + \ Old Symbol table sed-script +\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! + ghost + \ output symbol table to extra file + [ [IFDEF] fd-symbol-table ] + base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! + s" :" fd-symbol-table write-file throw + dup >ghostname fd-symbol-table write-line throw + [ [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 - (THeader over resolve T A, H 80 flag! ; + >in @ skip? IF 2drop EXIT THEN >in ! + dup 0< s" prims" T $has? H 0= and + IF + .sourcepos ." 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< s" prims" T $has? H 0= and + IF + .sourcepos ." needs doer: " >in @ bl word count type >in ! cr + THEN + ghost tuck swap resolve swap >magic ! ; + +Variable prim# +: first-primitive ( n -- ) prim# ! ; +: Primitive ( -- ) \ name + prim# @ T Alias H -1 prim# +! ; >CROSS \ Conditionals and Comments 11may93jaw @@ -380,70 +1755,178 @@ VARIABLE ;Resolve 1 cells allot Comment ( Comment \ -\ 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 (;code) ghost noop 2drop -ghost (.") ghost (S") ghost (ABORT") 2drop drop -ghost ' - \ compile 10may93jaw : compile ( -- ) \ name restrict? - name gfind dup 0= ABORT" CROSS: Can't compile " + 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 undefined? ABORT" CROSS: forward " >link @ ; + >TARGET -: ' ( -- cfa ) name gfind 0= ABORT" CROSS: undefined " - dup >magic @ = ABORT" CROSS: forward " >link @ ; -Cond: ['] compile lit ghost gexecute ;Cond +: ' ( -- 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 -\ tLiteral 12dec92py -: lit, ( n -- ) compile lit T , H ; -: alit, ( n -- ) compile lit T A, H ; +: [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 X c, tchar +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, + +\ if we dont produce relocatable code alit, defaults to lit, jaw +\ this is just for convenience, so we don't have to define alit, +\ seperately for embedded systems.... +T has? relocate H +[IF] +: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, +[ELSE] +: (alit,) ( n -- ) lit, ; ' (alit,) IS alit, +[THEN] + +: (fini,) compile ;s ; ' (fini,) IS fini, + +[IFUNDEF] (code) +Defer (code) +Defer (end-code) +[THEN] + +>TARGET +: Code + defempty? + (THeader there resolve + [ T e? prims H 0= [IF] T e? ITC H [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 + ; + +>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 +\ replaced >in by save-input + +: discard 0 ?DO drop LOOP ; \ 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 ; +: tcom ( x1 .. xn n name -- ) +\ dup count type space + gfind ?dup + IF >r >r discard r> r> + 0> IF >exec @ execute + ELSE gexecute THEN + EXIT + THEN + number? dup + IF 0> IF swap lit, THEN lit, discard + ELSE 2drop restore-input throw ghost gexecute THEN ; >TARGET \ : ; DOES> 13dec92py \ ] 9may93py/jaw : ] state on + Compiling comp-state ! BEGIN - BEGIN >in @ name - dup c@ 0= WHILE 2drop refill 0= + BEGIN save-input bl word + dup c@ 0= WHILE drop discard refill 0= ABORT" CROSS: End of file while target compiling" REPEAT tcom @@ -455,60 +1938,139 @@ Cond: [Char] ( "" -- ) restrict \ 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, depth T ] H ; + 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 - compile ;S state off + fini, + comp[ + state off ;Resolve @ IF ;Resolve @ ;Resolve cell+ @ resolve THEN + Interpreting comp-state ! ;Cond -Cond: [ restrict? state off ;Cond +Cond: [ restrict? state off Interpreting comp-state ! ;Cond >CROSS -: !does :dodoes tlastcfa @ tuck T ! cell+ ! H ; + +Create GhostDummy ghostheader + GhostDummy >magic ! + +: !does ( does-action -- ) +\ !! zusammenziehen und dodoes, machen! + tlastcfa @ [G'] :dovar killref +\ tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ; +\ !! geht so nicht, da dodoes, ghost will! + GhostDummy >link ! GhostDummy + tlastcfa @ >tempdp dodoes, tempdp> ; >TARGET Cond: DOES> restrict? - compile (;code) dodoes, tdoes @ ?dup IF @ T here H resolve THEN + compile (does>) doeshandler, + \ resolve words made by builders + tdoes @ ?dup IF @ T here H resolve THEN ;Cond -: DOES> dodoes, T here H !does depth T ] H ; +: DOES> switchrom doeshandler, T here H !does depth T ] H ; >CROSS \ Creation 01nov92py \ Builder 11may93jaw -: Builder ( Create do: "name" -- ) - >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 -- ) >end @ dup >magic @ <> - IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN - :dodoes T A, H gexecute T here H cell - reloff ; - -: TCreate ( -- ) - last-ghost @ - CreateFlag on +: 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 + + Make-Ghost ( Create-xt do:-xt ghost ) + rot swap ( do:-xt Create-xt ghost ) + >exec ! , ; +\ rot swap >exec dup @ ['] NoExec <> +\ IF 2drop ELSE ! THEN , ; + +: gdoes, ( ghost -- ) +\ makes the codefield for a word that is built + >end @ dup undefined? 0= + IF + dup >magic @ = + IF doer, + ELSE dodoes, + THEN + EXIT + THEN +\ compile :dodoes gexecute +\ T here H tcell - reloff + 2 refered + 0 fillcfa + ; + +: TCreate ( -- ) + executed-ghost @ + create-forward-warn + IF ['] reswarn-forward IS resolve-warning THEN Theader >r dup gdoes, - >end @ >exec @ r> >exec ! ; +\ stores execution semantic in the built word +\ if the word already has a semantic (concerns S", IS, .", DOES>) +\ then keep it + >end @ >exec @ r> >exec dup @ ['] NoExec = + IF ! ELSE 2drop THEN ; + +: RTCreate ( -- ) +\ creates a new word with code-field in ram + executed-ghost @ + 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, +\ stores execution semantic in the built word +\ if the word already has a semantic (concerns S", IS, .", DOES>) +\ then keep it + >end @ >exec @ r> >exec dup @ ['] NoExec = + IF ! ELSE 2drop THEN ; : Build: ( -- [xt] [colon-sys] ) - :noname postpone TCreate ; + :noname postpone TCreate ; + +: BuildSmart: ( -- [xt] [colon-sys] ) + :noname + [ T has? rom H [IF] ] + postpone RTCreate + [ [ELSE] ] + postpone TCreate + [ [THEN] ] ; : gdoes> ( ghost -- addr flag ) - last-ghost @ + executed-ghost @ state @ IF gexecute true EXIT THEN - cell+ @ T >body H false ; + >link @ T >body H false ; \ DO: ;DO 11may93jaw \ changed to ?EXIT 10may93jaw @@ -517,7 +2079,11 @@ Cond: DOES> restrict? here ghostheader :noname postpone gdoes> postpone ?EXIT ; -: ;DO ( addr [xt] [colon-sys] -- ) +: 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 @@ -527,71 +2093,155 @@ Cond: DOES> restrict? >TARGET \ Variables and Constants 05dec92py -Build: ; -DO: ( ghost -- addr ) ;DO +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 -by Create :dovar resolve +T has? rom H [IF] +Build: ( -- ) 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] + +T has? rom H [IF] +Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ; +by (Constant) +Builder 2Variable +[ELSE] +Build: T 0 , 0 , H ; +by Create +Builder 2Variable +[THEN] +T has? rom H [IF] +Build: ( -- ) 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 cell+ tudp ! ; + tudp @ dup T cell+ H tudp ! ; + : au, ( n -- udp ) tup @ tudp @ + T A! H - tudp @ dup cell+ tudp ! ; + tudp @ dup T cell+ H tudp ! ; + >TARGET -Build: T 0 u, , H ; -DO: ( ghost -- up-addr ) T @ H tup @ + ;DO +Build: 0 u, X , ; +by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO Builder User -by User :douser resolve -Build: T 0 u, , 0 u, drop H ; +Build: 0 u, X , 0 u, drop ; by User Builder 2User -Build: T 0 au, , H ; +Build: 0 au, X , ; by User Builder AUser -Build: ( n -- ) T , H ; -DO: ( ghost -- n ) T @ H ;DO -Builder Constant -by Constant :docon resolve +BuildSmart: T , H ; +by (Constant) +Builder Value -Build: ( n -- ) T A, H ; -by Constant -Builder AConstant +BuildSmart: T A, H ; +by (Constant) +Builder AValue -Build: T 0 , H ; -by Constant -Builder Value +BuildSmart: ( -- ) [T'] noop T A, H ; +by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO +Builder Defer -Build: ( -- ) compile noop ; +Build: ( inter comp -- ) swap T immediate A, A, H ; DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO -Builder Defer -by Defer :dodefer resolve +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 ; \ structural conditionals 17dec92py >CROSS : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; : sys? ( sys -- sys ) dup 0= ?struc ; -: >mark ( -- sys ) T here 0 , H ; -: >resolve ( sys -- ) T here over - swap ! H ; -: mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; + +: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw + +: >resolve ( sys -- ) + X here ( dup ." >" hex. ) over branchoffset swap X ! ; + +: TARGET \ Structural Conditionals 12dec92py @@ -600,108 +2250,290 @@ Cond: BUT restrict? sys? swap ;Con Cond: YET restrict? sys? dup ;Cond >CROSS -Variable tleavings + +Variable tleavings 0 tleavings ! + +: (done) ( addr -- ) + tleavings @ + BEGIN dup + WHILE + >r dup r@ cell+ @ \ address of branch + u> 0= \ lower than DO? + WHILE + r@ 2 cells + @ \ branch token + branchtoresolve, + r@ @ r> free throw + REPEAT r> THEN + tleavings ! drop ; + >TARGET -Cond: DONE ( addr -- ) restrict? tleavings @ - BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT - tleavings ! drop ;Cond +Cond: DONE ( addr -- ) restrict? (done) ;Cond >CROSS -: (leave T here H tleavings @ T , H tleavings ! ; +: (leave) ( branchtoken -- ) + 3 cells allocate throw >r + T here H r@ cell+ ! + r@ 2 cells + ! + tleavings @ r@ ! + r> tleavings ! ; >TARGET -Cond: LEAVE restrict? compile branch (leave ;Cond -Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond +Cond: LEAVE restrict? branchmark, (leave) ;Cond +Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond + +>CROSS +\ !!JW ToDo : Move to general tools section + +: to1 ( x1 x2 xn n -- addr ) +\G packs n stack elements in a allocated memory region + dup dup 1+ cells allocate throw dup >r swap 1+ + 0 DO tuck ! cell+ LOOP + drop r> ; +: 1to ( addr -- x1 x2 xn ) +\G unpacks the elements saved by to1 + dup @ swap over cells + swap + 0 DO dup @ swap 1 cells - LOOP + free throw ; + +: loop] branchto, dup TARGET \ Structural Conditionals 12dec92py -Cond: AHEAD restrict? compile branch >mark ;Cond -Cond: IF restrict? compile ?branch >mark ;Cond -Cond: THEN restrict? sys? dup T @ H ?struc >resolve ;Cond +>TARGET +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? T here H ;Cond +Cond: BEGIN restrict? branchtomark, ;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 -Cond: DO restrict? compile (do) T here H ;Cond -Cond: ?DO restrict? compile (?do) (leave T here H ;Cond -Cond: FOR restrict? compile (for) T here H ;Cond - ->CROSS -: loop] dup TARGET +\ Structural Conditionals 12dec92py -Cond: LOOP restrict? sys? compile (loop) loop] ;Cond -Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond -Cond: NEXT restrict? sys? compile (next) loop] ;Cond +:noname \ ?? i think 0 is too much! jaw + 0 compile (do) + branchtomark, 2 to1 ; + IS do, ( -- target-addr ) + +\ :noname +\ compile 2dup compile = compile IF +\ compile 2drop compile ELSE +\ compile (do) branchtomark, 2 to1 ; +\ IS ?do, + +:noname + 0 compile (?do) ?domark, (leave) + branchtomark, 2 to1 ; + IS ?do, ( -- target-addr ) +:noname compile (for) branchtomark, ; + IS for, ( -- target-addr ) +:noname 1to compile (loop) loop] compile unloop skiploop] ; + IS loop, ( target-addr -- ) +:noname 1to compile (+loop) loop] compile unloop skiploop] ; + IS +loop, ( target-addr -- ) +:noname compile (next) loop] compile unloop ; + IS next, ( target-addr -- ) + +Cond: DO restrict? do, ;Cond +Cond: ?DO restrict? ?do, ;Cond +Cond: FOR restrict? for, ;Cond + +Cond: LOOP restrict? sys? loop, ;Cond +Cond: +LOOP restrict? sys? +loop, ;Cond +Cond: NEXT restrict? sys? next, ;Cond \ String words 23feb93py -: ," [char] " parse string, T align H ; +: ," [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 ; +: IS T >address ' >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 ; +: linked X here over X @ X A, swap X ! ; +: chained T linked A, H ; : err" s" ErrLink linked" evaluate T , H - [char] " parse string, T align H ; + [char] " parse T string, align H ; : env" [char] " parse s" EnvLink linked" evaluate - string, T align , H ; + T string, align , H ; : 2env" [char] " parse s" EnvLink linked" evaluate - here >r string, T align , , H + 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 - name gfind dup 0= ABORT" CROSS: Can't compile" + 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 + ELSE compile (compile) addr, THEN THEN ;Cond Cond: postpone ( -- ) restrict? \ name - name gfind dup 0= ABORT" CROSS: Can't compile" + 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 + ELSE compile (compile) addr, THEN THEN ;Cond + +\ save-cross 17mar93py + +hex + +>CROSS +Create magic s" Gforth2x" here over allot swap move + +bigendian 1+ \ strangely, in magic big=0, little=1 +tcell 1 = 0 and or +tcell 2 = 2 and or +tcell 4 = 4 and or +tcell 8 = 6 and or +tchar 1 = 00 and or +tchar 2 = 28 and or +tchar 4 = 50 and or +tchar 8 = 78 and or +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" --image-file" 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 ; + +\ \ minimal definitions + +>MINIMAL also minimal ->MINIMAL -also minimal \ Usefull words 13feb93py : KB 400 * ; +\ \ [IF] [ELSE] [THEN] ... 14sep97jaw + +\ it is useful to define our own structures and not to rely +\ on the words in the compiler +\ The words in the compiler might be defined with vocabularies +\ this doesn't work with our self-made compile-loop + +Create parsed 20 chars allot \ store word we parsed + +: upcase + parsed count bounds + ?DO I c@ toupper I c! LOOP ; + +: [ELSE] + 1 BEGIN + BEGIN bl word count dup WHILE + comment? 20 umin parsed place upcase parsed count + 2dup s" [IF]" compare 0= >r + 2dup s" [IFUNDEF]" compare 0= >r + 2dup s" [IFDEF]" compare 0= r> or r> or + IF 2drop 1+ + ELSE 2dup s" [ELSE]" compare 0= + IF 2drop 1- dup + IF 1+ + THEN + ELSE + 2dup s" [ENDIF]" compare 0= >r + s" [THEN]" compare 0= r> or + IF 1- THEN + THEN + THEN + ?dup 0= ?EXIT + REPEAT + 2drop refill 0= + UNTIL drop ; immediate + +: [THEN] ( -- ) ; immediate + +: [ENDIF] ( -- ) ; immediate + +: [IF] ( flag -- ) + 0= IF postpone [ELSE] THEN ; immediate + +Cond: [IF] postpone [IF] ;Cond +Cond: [THEN] postpone [THEN] ;Cond +Cond: [ELSE] postpone [ELSE] ;Cond + \ define new [IFDEF] and [IFUNDEF] 20may93jaw -: there? name gfind IF >magic @ <> ELSE drop false THEN ; +: defined? tdefined? ; +: 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 ] literal search-wordlist + dup IF nip THEN ; + +: [IFDEF] >in @ directive? swap >in ! + 0= IF tdefined? ELSE name 2drop true THEN + postpone [IF] ; + +: [IFUNDEF] tdefined? 0= postpone [IF] ; + +Cond: [IFDEF] postpone [IFDEF] ;Cond -: [IFDEF] there? postpone [IF] ; -: [IFUNDEF] there? 0= postpone [IF] ; +Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond \ C: \- \+ Conditional Compiling 09jun93jaw -: C: >in @ there? 0= - IF >in ! T : H +: C: >in @ tdefined? 0= + IF >in ! X : ELSE drop BEGIN bl word dup c@ IF count comment? s" ;" compare 0= ?EXIT @@ -710,71 +2542,116 @@ also minimal AGAIN THEN ; -also minimal +: d? d? ; -: \- there? IF postpone \ THEN ; -: \+ there? 0= IF postpone \ THEN ; +\G doesn't skip line when debug switch is on +: \D D? 0= IF postpone \ THEN ; -: [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 +\G interprets the line if word is not defined +: \- tdefined? IF postpone \ THEN ; -\ save-cross 17mar93py +\G interprets the line if word is defined +: \+ tdefined? 0= IF postpone \ THEN ; -\ i'm not interested in bigforth features this time 10may93jaw -\ [IFDEF] file -\ also file -\ [THEN] -\ included throw after create-file 11may93jaw +Cond: \- \- ;Cond +Cond: \+ \+ ;Cond +Cond: \D \D ;Cond -bigendian Constant bigendian +: ?? bl word find IF execute ELSE drop 0 THEN ; -: save-cross ( "name" -- ) - bl parse ." Saving to " 2dup type - w/o bin create-file throw >r - image @ there r@ write-file throw - bit$ @ there 1- cell>bit rshift 1+ r@ write-file throw - r> close-file throw ; +: needed: +\G defines ghost for words that we want to be compiled + BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ; \ words that should be in minimal -: + + ; : 1- 1- ; -: - - ; : 2* 2* ; -: * * ; : / / ; -: dup dup ; : over over ; -: swap swap ; : rot rot ; +create s-buffer 50 chars allot -\ include bug5.fs -\ only forth also minimal definitions +bigendian Constant bigendian -: \ postpone \ ; -: ( postpone ( ; +: here there ; +: equ constant ; +: mark there constant ; + +\ compiler directives +: >ram >ram ; +: >rom >rom ; +: >auto >auto ; +: >tempdp >tempdp ; +: tempdp> tempdp> ; +: const constflag on ; +: warnings name 3 = 0= twarnings ! drop ; +: | ; +\ : | NoHeaderFlag on ; \ This is broken (damages the last word) + +: 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 + ; +: 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 ['] forced? IS skip? ; +: needed-words ['] needed? IS skip? ; +: undef-words ['] defined2? IS skip? ; +: skipdef skipdef ; + +: \ 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 +: times 0 ?DO dup X c, LOOP drop ; \ used for space table creation + +\ only forth also cross also minimal definitions order \ cross-compiler words : decimal decimal ; : hex hex ; -: tudp T tudp H ; -: tup T tup H ; minimal +\ : tudp X tudp ; +\ : tup X tup ; + +: doc-off false to-doc ! ; +: doc-on true to-doc ! ; + +[IFDEF] dbg : dbg dbg ; [THEN] \ for debugging... : order order ; -: words words ; +: hwords words ; +: words also ghosts words previous ; : .s .s ; - : bye bye ; \ turnkey direction @@ -782,14 +2659,29 @@ only forth also minimal definitions : T minimal ; immediate : G ghosts ; immediate -: turnkey 0 set-order also Target definitions - also Minimal also ; +: turnkey + \GFORTH 0 set-order also ghosts + \ANSI [ ' ghosts >wordlist ] Literal 1 set-order + also target definitions + also Minimal also ; \ these ones are pefered: : lock turnkey ; -: unlock forth also cross ; +: unlock previous forth also cross ; + +\ also minimal +: [[ also unlock ; +: ]] previous previous also also ; unlock definitions also minimal : lock lock ; lock + +\ load cross compiler extension defined in mach file + +UNLOCK >CROSS + +[IFDEF] extend-cross extend-cross [THEN] + +LOCK