\\           *** Save Module tree ***                  17jan98py Diese Datei enthält den Code, um ein Modul zu sichern. Dazu    müssen die Adressen in die Modul-spezifische Form gewandelt     werden. Es wird ein Array aller Module angelegt, in dem die     Einträge Anfang, Länge und Verkettungszeiger liegen. Als letzterEintrag steht ein Modul mit dem Anfang 0 und der Länge $7FFF    um Nil- und System-Adressen abzufangen und zu markieren.        Fehleinträge werden nicht reloziert.                             Der Loader wird ebenfalls erzeugt; die zu linkenden Dateien    sind im DATA-Segment untergebracht, in der Reihenfolge, in der  geladen und gelinkt wird, abgeschlossen durch einen 0-String.   Das BSS-Segment wird als Stack-Area verwendet, STACKSPACE sollteden Wert von $8000 unbedingt behalten (groáer Heap-Bedarf im    Target-Compiler!!!).                                                                                                                                                                            \ Loadscreen                                           20may00pyModule Saving                                                   DOS also  Memory also  Saving                                    $1 $0E +thru   \ load savemod                                  $0F $10 +thru   \ load modules                                  $11 $18 +thru   \ load import                                   export Saving savemod savesystem modules m' import 'bye                apply cp ;                                               bye:  r>  lasterr @ 0< 0=  IF  flush  THEN                            [ user' >tib udp 8+ + ] ALiteral  off >r ;                main: >in @ name dup count + cell- s" .fm" swap capscomp 0=           IF  nip 0 over count + c! 1+ r/o fopen dup ?diskabort               dup >r getheader r@ takeit r> fclose ?diskabort                 (apply  ELSE  drop >in !  THEN ;                      toss toss                                                       Module;                                                         \ Module-Loader saving                                 07jul01py| : +suffix ( addrx ux addr u -- addr' )                            2dup dup 4- 0 max /string s" .exe" drop capscomp 0= -4 and +    tuck pad swap move pad +  swap move pad ;                   | : .file ( addr len -- addr' )  0 arg +suffix ;                [IFDEF] go32                                                    | : sysfile [ S" .SYS "  2dup + 1- 0 swap c! ] SLiteral .file ; | : comfile [ S" .COM "  2dup + 1- 0 swap c! ] SLiteral .file ; [THEN] [IFDEF] unix                                             | : sysfile [ S" .fi "   2dup + 1- 0 swap c! ] SLiteral .file ; | : comfile [ S"  "      2dup + 1- 0 swap c! ] SLiteral .file ; [THEN] [IFDEF] win32                                            | : sysfile [ S" .FI "   2dup + 1- 0 swap c! ] SLiteral .file ; | : comfile [ S" .EXE "  2dup + 1- 0 swap c! ] SLiteral .file ; [THEN]                                                                                                                          \ Module-Loader saving                                 22jan10py                                                                : cp ( from0 len0 to1 len1 -- )  2swap                            r/o open-file throw >r r/w exe create-file throw r>             $4000 NewPtr >r                                                 BEGIN  r@ $4000 2 pick filehandle @ fread 0 max                        r@ swap 3 pick filehandle @ fwrite $4000 < UNTIL         r> DisposPtr  close-file throw close-file throw ;                                                                             : ?cp ( from0 len0 to1 len1 -- )                                  2dup file-status nip 0= IF  2drop 2drop  EXIT  THEN  cp ;                                                                                                                                                                                                                                                                                                                                     \ Module-Loader saving                                 07jul01py                                                                | : a.text  FORTHstart -$1000 and ;                             | : a.data  Mroot      -$1000 and ;                             | FORTHstart 2+ count + $A + a.text - Constant dateoffset                                                                       [IFDEF] go32                                                    : saveloader ( -- ) name count  mroot $1C + @ @ >len 2over cp     2dup + s" .COM"  rot swap move 4+ comfile >len 2swap ?cp ;    [THEN] [IFDEF] win32                                            : saveloader ( -- ) name count                                    2dup + s" .exe"  rot swap move 4+ comfile >len 2swap ?cp ;    [THEN] [IFDEF] unix                                             : saveloader ( -- ) name count                                    comfile >len 2swap ?cp ;                                      [THEN]                                                          \ Vocabular sichern                                    05mar95py                                                                | : thruMod ( module -- )  dup                                      BEGIN  BEGIN  dup 8+ @  dup  WHILE  nip  REPEAT drop                   BEGIN  dup r@ execute 2dup = IF 2drop rdrop exit THEN                  $10 + dup @ 0= WHILE cell- @ REPEAT @ AGAIN ; | : voc! ( module end -- ) 0 >r voc-link                            BEGIN  dup @ dup  WHILE  swap >r dup 2over within                      IF dup @ r@ ! r> r> rot dup >r ! ELSE rdrop THEN         REPEAT 2drop 2drop r> dup BEGIN dup @ WHILE @ REPEAT ! ;    | : vocs! thruMod  dup dup @ + voc! ;                                                                                           | : vocs@ thruMod [ ModHeader 8+ ] Literal + name> >body 8+               dup dup BEGIN  @ dup  WHILE  dup 'initvoc                                      2dup = UNTIL THEN =                              IF dup @ voc-link @ rot ! voc-link ! ELSE drop THEN ; \ Tabelle einrichten                                   30jan97py                                                                | : segments ( len -- segs )  1- $10 >> 1+ ; hmacro             | : tab, ( addr len -- )  dup segments                              0 ?DO  maxmodlen segments                                              0 ?DO  over , 2dup $FFFF umin + , 0 , I w, J w, 0 ,             LOOP  $10000 /string  LOOP  2drop ;                                                                                  | : (inittab ( root -- ) recursive                                  BEGIN  dup dup @ tab, dup 8+ @ ?dup                                    IF  (inittab  THEN  $10 + @  dup 0=  UNTIL  drop ;   | : inittab ( -- tabstart )  savedp                                 here Mroot @ (inittab 0 $7FFF tab, ;                                                                                                                                                                                                                        \ Tabelle im Loader-Format generieren                  30jan97py\ Format: { len.2 { count.1 chars.count date.4                  \ modpart.2 pathpart.2 abs.2 rel.2 }*.len }                                                                                     | : name, ( tab -- tab )  dup $10 + off                             dup @ over $E + w@ $10 << - dup $30 + count  here place         here c@ 1+ allot $14 + @ ,                                      dup $C + @ , dup 8+ dup @ , off ;                                                                                           | : >LinkTab ( tabstart module -- linktabstart )                    here  0 w,  >r  over                                            BEGIN  2dup @ = 0=  WHILE  $14 +  REPEAT  name, 2drop           BEGIN  dup @  WHILE  dup $10 + @  IF name, THEN  $14 +          REPEAT  [ " nil" @ ] Literal , 0 , 8+ dup @ , dup off 8+ off    here r@ - 2- r@ w!  r> ;                                                                                                    \ Module umformen, in Datei schreiben...               30jan97py                                                                Label >tab  BEGIN  AX BX ) cmp                                                     u<= IF  AX 4 BX D) cmp                                                  u>= IF  CX push  CX $10 # shr                                           .w CX $C BX D) cmp  CX pop                                      0= IF  BX ) AX sub  ret  THEN                   THEN  THEN  0 # BX ) cmp                                        $14 BX D) BX lea  0= UNTIL                               stc  ret                                                                                                            | Code ((savemod ( module tab handle -- return )                       CX pop  DX pop   R: pusha   CX DI mov   DX SI mov               4 SI D) BP mov   SI BP add   SI ) DX mov   CX CX xor                                                                                                                                     \ Module umformen, in Datei schreiben...               10mar97py                                                                       BEGIN  CX 0 BP D) btr  CX inc                                       b IF  DI BX mov  CX 0 BP D) btr  CX dec                               b IF  4 CX SI DI) AX lea  -4 AX D) AX add                             >tab rel) call  2 BX D) BX lea                            ELSE  CX SI I) AX mov  >tab rel) call  THEN                     nb IF  $10 # AX shl  .w 8 BX D) AX mov                                 0 # $10 BX D) bts                                               nb IF  .w CX AX mov  THEN                                       AX CX SI I) mov  .w CX 8 BX D) mov  THEN                 4 # CX add  THEN                                          CX DX cmp  u<= UNTIL                                                                                                                                                                                                                                 \ Module umformen, in Datei schreiben...               14dec08py[IFDEF] go32                                                         pusha  SI ) CX mov  SI DX mov  $3C SP D) BX mov                 $40 # AH mov   $21 # int  b IF  AX AX movzx  AX neg  THEN       AX $3C SP D) mov  popa                                     [THEN] [IFDEF] unix                                                  pusha  SI ) CX mov  $3C SP D) BX mov                            SP DI mov  -$10 # SP and  CX push                               CX push  SI push  BX push   Label '_write  0 L# AX mov          AX call  DI SP mov  AX $3C SP D) mov  popa                      4 SI D) DX mov  SI DX add  \ relocate DI: tab              [THEN] [IFDEF] win32                                                 pusha  SI ) CX mov  $3C SP D) BX mov                            CX push  SI push  BX push   Label '_write  0 L# AX mov          AX call  AX $3C SP D) mov  popa                                 4 SI D) DX mov  SI DX add  [THEN]   \ relocate DI: tab     \ Module umformen, auf Diskette sichern...             30jan97py     BEGIN   DI ) BP mov  CX CX xor                                          .w $C DI D) AX mov  AX $10 # shl                               .w $E DI D) BX mov  BX $10 # shl  .w 8 DI D) AX mov \ AX: next SI: Module, BP: Link, BX: rel, CX: pos, BX: addr             BEGIN  .w AX CX cmp  AX CX mov  0<> WHILE                              .w CX SI I) AX mov  .w 2 CX SI DI) BX mov                       BP BX add  BX CX SI I) mov   BP BX sub                          CX DX ) bts  REPEAT                                      .w $A DI D) AX mov  SI BP sub  4 # BP sub  CX CX xor            BEGIN  .w AX CX cmp  AX CX mov  0<> WHILE  BX push                     .w CX SI I) AX mov  .w 2 CX SI DI) BX mov                       BP BX add  CX BX sub  BX CX SI I) mov  BX pop                   CX DX ) bts  CX inc  CX DX ) bts  CX dec                 REPEAT  4 SI BP DI) BP lea  BP BP test  0<> WHILE               $14 # DI add  REPEAT  popa  Next end-code               \ savemod savesystem                                   07jul01py| Variable handle               | Variable modtab               | : ?abort ( diskerr -- ) dup 0< IF r0 @ rp! ELSE drop THEN ;   | : (savemod ( back linkpos module -- )                         [IFDEF] unix  s" write"   & libc     cell+ @ procaddr  [THEN]   [IFDEF] win32 s" _hwrite" & kernel32 cell+ @ procaddr  [THEN]   [IFUNDEF] go32  '_write 1+ !  [THEN]                                dup 8+ @ >r  dup $C + @ >r  dup $10 + @ >r  >r                  dup  IF  0 handle @ 1 fseek >r handle @ 0 fseek ?abort                   rp@ 4 handle @ fwrite ?abort                                    r@ handle @ 0 fseek ?abort r>  THEN  drop              r@ $C + ! r@ 8+ off  r@ $10 + off                               r@ modtab @ handle @ ((savemod                                  r> r> over $10 + !  r> over $C + !  r> over 8+ ! >r             ?abort  modtab @ r> >linktab                                    dup dup w@ 2+ handle @ fwrite ?abort dp ! ( ." saved" ) ;   \ savemod savesystem                                   20may00py                                                                | : getmodname ( flag -- addr ) >r Name  count pad place pad        0 over count + c!  count over + 3 - dup c@ Ascii . =            IF  0 swap c!  ELSE  drop  THEN  >len over +                    r> IF S" .fi" ELSE S" .fm" THEN                                 >r over r> move  0 swap 3 + c! ;                                                                                            | : >savemod ( back linkpos module -- )  recursive >r               BEGIN  >r 0 handle @ 1 fseek over r> r@ (savemod                       r@ 8+ @ ?dup  IF  >r dup dup 8+ r> >savemod  THEN               over 0< 0= r> $10 + @ and                                       dup  WHILE  >r $10 +  REPEAT  drop 2drop ;                                                                                                                                                                                                           \ savemod savesystem                                   12mar00py| : (vocs@  r> & 'initvoc push ['] drop IS 'initvoc vocs@ ;     : savemod ( addr -- ) ['] ?diskabort >r r0 push dp push rp@ r0 !  dup Mroot @ = getmodname                                        1 lasterr ! flush save PushHeap  over ModuleBye                 [IFDEF] go32 0 [ELSE] r/w [THEN] fcreate dup ?abort  handle !   dup Mroot @ = 0= IF dup >r ['] (vocs@ >r dup vocs! THEN         rp@ r0 !       inittab modtab !                                 -1 0 2 pick >savemod handle @ fclose                            swap Mroot @ = ?EXIT   \ All is save, keep on running           dup 0< ?EXIT drop sysfile r/w fopen dup 0< ?EXIT                [ udp Mroot @ - ] Literal over 0 fseek dup 0< ?EXIT drop        udp @ dup sp@ 2 cells 4 pick fwrite dup 0< ?EXIT drop 2drop     fclose ;                                                      : savesystem  savedp >in @ >r Mroot @ savemod r@ >in !            r> >in ! saveloader ;                                         \ modules                                              01nov06py                                                                | : .module  cr spaces dup $30 + .name                              $20 col - spaces ( Start:) dup 8 .r                             ( DP:) dup @ 8 .r ( Länge:) dup cell+ @ 8 .r ;                                                                              : modules ( -- ) cr ." Modul" $20 col - spaces                    ."    Start      DP   Size"  0 Mroot @                          BEGIN  BEGIN  over .module  dup 8+ @  dup  WHILE                              >r drop 4+ r>  REPEAT  drop                              BEGIN  over 0= IF 2drop exit THEN  $10 + dup @                         0= WHILE  >r 4- r>  cell- @  REPEAT @ stop?       UNTIL  2drop ;                                                                                                                                                                                                                                                \ m' error recovery                                    20may00py                                                                : m' name capitalize mroot @ findmod dup 0= abort" No Module" ;                                                                 ?head @ 1 ?head !                                               ModHeader $28 + Constant AllHeader                              Create filebuf  AllHeader allot                                 : getHeader  >r  filebuf AllHeader r> fread ?diskabort ;        Create *.FM    here ," *.fm" c>0"                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               \ discard discardit                                    15aug98py                                                                Variable discard                                                : (discardit recursive                                            BEGIN  dup  WHILE  dup 8+ @ (discardit dup $10 + @                     swap cell- DisposPtr  REPEAT  drop ;                   : discardit ( module -- )                                         dup $C + dup cell+ dup @ -rot off @ 8+ ! (discardit ;         : ?error ( flag -- ) dup 0< 0= IF drop exit THEN                  discard @ dup IF  discardit discard off  ELSE  drop  THEN       dup -$100 = IF abort" unknown modul!" THEN ?diskabort ;                                                                                                                                                                                                                                                                                                                                       \ findm                                                05mar95py                                                                Label findm  " nil" @ # BX ) cmp  0= IF  BP BP xor  ret  THEN   Label (findm                                                          BEGIN  DX ) AX mov  $14 BP D) AX cmp                                   0=  IF  $30 BP D) SI lea  BX DI mov                                     .b BX ) CX movzx  CX inc                                        repe .b cmps  0= IF  ret  THEN  THEN                    8 BP D) AX mov  AX AX test                                      0<> IF  BP push  AX BP mov  (findm rel) call                            AX pop  0= IF  ret  THEN  AX BP mov  THEN               $10 BP D) AX mov  AX AX test  0<> WHILE  AX BP mov       REPEAT  AX AX xor  AX dec  ret                                                                                                                                                                                                                            \ link-thread                                          30jan97py                                                                Label link-thread   \ AX: startoffset  SI: Source  BP: link           SI DI mov  4 SI D) DI add  CX CX xor  AHEAD                     BEGIN  .w CX SI I) AX mov  .w 2 CX SI DI) BX mov                       0 BP BX DI) DX lea  DX CX SI I) mov  CX DI ) bts         BUT THEN  .w AX CX cmp  AX CX mov  0= UNTIL  ret                                                                          Label link-rel     \ AX: startoffset  SI: Source  BP: link            SI DI mov  4 SI D) DI add  CX CX xor  AHEAD                     BEGIN  .w CX SI I) AX mov  .w 2 CX SI DI) BX mov                       -4 BP BX DI) DX lea  CX DX sub  SI DX sub                       DX CX SI I) mov   CX DI ) bts  CX inc  CX DI ) bts              CX dec                                                   BUT THEN  .w AX CX cmp  AX CX mov  0= UNTIL  ret                                                                          \ link (uses part of the loader...)                    29dec96py                                                                | : linkerr ( addr -- )  count here place  -$100 ?error ;                                                                       Code link   ( linktab -- )  pusha  AX DI mov  AHEAD                  BEGIN  .b DI ) AX movzx   pusha                                        & mroot A#) BP mov  DS: 0 BP D) BP mov                          1 DI AX DI) DX lea  DX SP ) mov  DI BX mov                      findm rel) call  BP 8 SP D) mov  popa                           0<> IF  BX $1C SP D) mov  popa  ;c: linkerr >c:                 THEN                                                            BP BP test  0<> IF  4 # DI add  THEN                            SI SI test  0= IF  BP SI mov  THEN                                                                                                                                                                                                                  \ link (uses part of the loader...)                    29dec96py                                                                            .w   DI  ) AX mov  $10 # AX shl                                 .w 2 DI D) BX mov  $10 # BX shl                                 .w 4 DI D) AX mov  DI push                                      link-thread rel) call  DI pop                                   .w 6 DI D) AX mov      DI push                                  link-rel rel) call  DI pop                                      $8 # DI add                                                     BP BP test  YET  0= UNTIL                                                                                                BUT THEN  SI SI xor  DI ) DX movzx  DI inc  DI inc              DX DX test  0= UNTIL  popa  AX pop                              Next end-code                                                                                                                                                                              \ takeit                                               05mar95py: (takeit  ( back link handle -- )                                filebuf cell+ @ dup 1- 3 >> 1+ + cell+ dup NewPtr >r            discard @ 0= IF  r@ cell+ discard !  THEN                       r@ swap erase 1 r@ ! r> cell+ >r  filebuf r@ AllHeader move     r@ filebuf @ AllHeader /string  2 pick  fread ?error            here 2 2 pick fread ?error                                      here dup w@ 2+ dup allot 2 /string rot fread ?error             dup @ r@ $10 + !  r@ swap !  r> $C + ! ;                      : loadmod ( back link handle -- )  recursive >r                   BEGIN  2dup r@ (takeit  @  dup 8+ @ ?dup                               IF  dup dup 8+ filebuf 8+ @ r@ position ?error                      r@ getHeader r@ loadmod  THEN                               over thismodule @ = 0= [ filebuf $10 + ] ALiteral @             and dup WHILE  r@ position ?error  $10 +                        r@ getHeader  REPEAT  rdrop drop 2drop ;               \ takeit                                               29dec96py                                                                : takeit ( handle -- module ) here modtab !                       >r thismodule @ dup 8+ r> loadmod    0 w,                       modtab @ link modtab @ dp ! thismodule @ 8+ @                   dup $10 + dup push off dup ModuleCold  -1 over cell- +! ;     : fimport ( handle name -- module t / f ) >r  recursive           BEGIN  dup getHeader  r@ dup c@ 1+                                     [ filebuf ModHeader 8+ + ] ALiteral -text                       0= IF  takeit  rdrop true exit  THEN >r                         [ filebuf $10 + ] ALiteral @ r>                                 [ filebuf 8+    ] ALiteral @ ?dup                               IF  over position ?error dup r@ fimport                             IF  rdrop nip nip true exit  THEN  THEN                     over  WHILE  under position ?error                       REPEAT  2drop rdrop false ;                                   \ import apply                                         20may00py: name-import? ( addr u module -- f ) >r                          r/o open-file ?error dup filehandle @ r> rot >r                 fimport r> close-file ?error ;                                : search-import ( name -- ) >r                                  [IFDEF] go32  dta fsetdta  [THEN]  *.fm 7 fsfirst                     BEGIN  0= WHILE  dtaname  >len r@ name-import?                         0= WHILE  fsnext  REPEAT                                 ELSE  true abort" can't find "  THEN ;                    : (import  >in @ Name capitalize mroot @ FindMod dup 0=           IF  drop >in !  [ S" .fm "  2dup + 1- 0 swap c! ] SLiteral          Name >r r@ count +suffix >len r@ capitalize name-import?        0= IF  r@ search-import  THEN  rdrop                        ELSE  drop  THEN  discard off ;     ?head !                   : import ( <name> -- ) (import dup cell- 1 over +! @ 1 =          IF dup vocs@ THEN dup [ ModHeader cell- ] Literal + perform ; \ import apply                                         09mar97py                                                                | : (bye ;                                                      Defer 'bye      ' bye IS 'bye                                   | : (apply ( module -- ) dup >r $1C + perform                       r@ cell- @ 0> 0= IF r@ ModuleBye r@ discardit THEN rdrop ;  : apply ['] (bye IS 'bye                                          (import (apply ['] bye IS 'bye ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              \ blocks>file                                     32b  01jan01py                                                                DOS also                                                                                                                        | Variable bhandle                                                                                                              : blocks>file   ( from to -- )   \ reads bl terminated string      bl word count  ?dup 0= abort" missing filename"                 over + 0 swap c!                                                [IFDEF] go32 0 [ELSE] r/w [THEN]  fcreate                       dup 0< abort" check name"  bhandle !                            1+ swap ?DO  I block b/blk bhandle @ fwrite                                          dup ?diskabort                                                  b/blk - abort" disk full!"  LOOP           bhandle @ fclose  ( -$41 case? ?EXIT ) ?diskabort ;          toss forth