\\   ###   Main Directory   ###                   mod  19may97py                                                                Generic loader           $0001                                  GO32                     $0002                                  OS/2                     $0003                                  Linux                    $0004                                  Windows 32               $0005                                                                                                  Quelltext                $0008                                                                                                  Terminal                 $00B0                                  GO32-specific            $00C0                                  OS/2-specific            $00D0                                  Linux-specific           $00E0                                  Win32-specific           $00F0                                  Opttab                   $0100                                  \ generic 386   bigFORTH loadscreen                    09oct09py\ based on  volksFORTH-83, developed by                         \ K. Schleisiek, B. Pennemann, G. Rehfeld & D. Weineck          \ Atari ST - 32-bit Version implemented by D. Weineck and       \ bigFORTH Version implemented by B. Paysan                     \ 386 32-bit Version implemented by B. Paysan                                                                                   Onlyforth [IFUNDEF] Target  include target.fb [THEN] Onlyforth  [IFDEF] :GO32  1 +load [ELSE]                                    [IFDEF] :OS/2  2 +load [ELSE]                                    [IFDEF] :Linux 3 +load [ELSE]                                    [IFDEF] :Bsd   3 +load [ELSE]                                    [IFDEF] :Win32 4 +load [ELSE]                                    [IFDEF] :OSX   5 +load [ELSE]                              [THEN] [THEN] [THEN] [THEN] [THEN] [THEN]                       cr .unresolved Onlyforth                                        \ GO32 loadscreen                                      20jun01py                                                                \ GO32 Version implemented by B. Paysan                                                                                         Target                                                          $08 $11 thru                                                    $C0     load                                                    $12 $85 thru                                                    $C1 $C3 thru                                                    $86 $A5 thru                                                    $C4 $C5 thru                                                    $A6     load                                                    $C6 $C9 thru                                                    $B0 $B6 thru                                                    $A7 $A8 thru                                                                                                                    \ OS/2 loadscreen                                      14dec08py                                                                \ OS/2 Version implemented by B. Paysan                                                                                         Target                                                          $08 $85 thru                                                    $D0 $D5 thru                                                    $86 $A5 thru                                                    $D6     load                                                    $A6     load                                                    $D7 $DC thru                                                    $B0 $B4 thru  $B6 load                                          $A7 $A8 thru                                                                                                                                                                                                                                                    \ Linux loadscreen                                     12jan10py[IFDEF]   bsd   : :bsd ;   [ELSE]  [IFUNDEF] :bsd               [IFUNDEF] libc5 : :glibc ; [THEN]  [THEN]  [THEN]  : :unix ;    Target                                                          $08 $85 thru                                                    $D0 $D8 thru                                                    $E2 $E5 thru                                                    $86 $A5 thru                                                    $E7     load                                                    $DB     load                                                    $A6     load                                                    $DC $DE thru                                                    $E6     load                                                    $E0 $E1 thru                                                    $B0 $B4 thru  $B6 load                                          $A7 $A8 thru                                                    \ Win 32 loadscreen                                    14dec08py                                                                \ Win32 Version implemented by B. Paysan                        Target                                                          $08 $85 thru                                                    $D0 $D8 thru                                                    $F0 $F2 thru                                                    $86 $A5 thru                                                    \ $F4     load                                                  $DB     load                                                    $A6     load                                                    $DC $DE thru                                                    $E6     load                                                    $E0 $E1 thru                                                    $B0 $B6 thru                                                    $A7 $A8 thru                                                    \ Mac OS X loadscreen                                  22jan10py: :unix ;                                                       : :bsd ;                                                        Target                                                          $08 $85 thru                                                    $D0 $D8 thru                                                    $E2 $E5 thru                                                    $86 $A5 thru                                                    $E7     load                                                    $DB     load                                                    $A6     load                                                    $DC $DE thru                                                    $E6     load                                                    $E0 $E1 thru                                                    $B0 $B4 thru  $B6 load                                          $A7 $A8 thru                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    \ FORTH Preamble and ID                           mod  14jan01pyMODULE Kernel                                                   Code exit       R: ret  Next end-code restrict macro  :r :r T&P : noop ; macro                                                  Code 2drop ( n -- ) AX pop AX pop Next end-code macro 0 :ax T&P Code drop ( n -- ) AX pop  Next end-code macro 0 :ax T&P        : D>S  drop ;                                                   Code dup ( n -- n n )   AX push  Next end-code macro            | Code lit      AX push  0 # AX mov                                             Next end-code macro  :lit :lit T&P              Code (User    ( -- uaddr )  AX push   0 UP L) AX lea                          Next end-code  macro  :ax :user T&P               Code (sUser   ( -- uaddr )  AX push   0 UP D) AX lea                          Next end-code  macro  :ax :suser T&P              $400 Constant maxudp                                            Variable udp  0 ,  here origin!  here maxudp dup allot  erase   \ Tasks User Variables                                 29mar94pyAUser Tnext                        \ points to next task        AUser Tprev                        \ points to previous task    AUser TsaveRP                      \ Save Returnstack Pointer   AUser Tsave        ' noop Tsave  ! \ context save & restore     AUser Tstart       ' noop Tstart !                              AUser Lock>                        \ Link between Locks         AUser s0                                                        AUser r0                                                        AUser handler                                                   AUser dp                                                        AUser s^                                                        User  base         &10 base !                                   AUser output                                                    AUser input                                                     User  wake-time    0 wake-time !                                \ User Variables                                       27dec92pyAUser errorhandler                                              AUser "error                                                    AUser thisModule                                                AUser exportlink                                                User  state                                                     User  >tib                                                      User  >in                                                       User  blk                                                       User  line              -1 line !                               AUser loadfile                                                  User  dpl               -1 dpl !                                User  scr               1 scr !                                 User  r#                                                        AUser isfile                       \ addr of file control block AUser fromfile                                                  \ manipulate system pointers                           04apr93py                                                                Code sp@  ( -- addr )   AX push   SP AX mov                                             Next end-code macro  :ax 0 T&P                                                                          Code sp!  ( addr -- )   AX SP mov  AX pop                                               Next end-code macro  0 :ax T&P                                                                          Code up@  ( -- addr )   AX push   UP AX mov                                             Next end-code macro  :ax 0 T&P                                                                          Code up!  ( addr -- )   AX UP mov   AX pop                                              Next end-code macro  0 :ax T&P                                                                                                                                                                                                          \ manipulate returnstack                               12mar00py                                                                Code rp@  ( -- addr )   AX push   RP AX mov                                             Next end-code macro  :ax 0 T&P                                                                          Code rp!  ( addr -- )   AX RP mov  AX pop                                               Next end-code macro  0 :ax T&P                                                                          ' exit Alias unnest                                                                                                             Code execute   ( cfa -- )    R: AX DX mov  lods  DX call             Next  end-code macro  :r :r T&P                            Code perform   ( cfa -- )    R: AX DX mov  lods  DX ) call           Next  end-code macro  :r :r T&P                                                                                                                                                            \ r@ rdrop unnest, execute                             01nov01pyCode r@  ( -- n )       AX push  RP ) AX mov                                            Next end-code macro  :ax 0 T&P          Code rdrop                                                           cell # RP add      Next end-code  restrict macro           Code >r   ( n -- )      AX -4 RP D) mov  cell # RP sub  AX pop                          Next end-code macro restrict 0 :ax T&P  Code r>   ( -- n )      AX push  RP ) AX mov  cell # RP add                             Next end-code macro restrict :ax 0 T&P  Code 2r@  ( -- d )  AX push  4 SI D) push  SI ) AX mov               Next end-code macro  :ax 0   T&P  restrict                 Code 2r>  ( -- d )  AX push  4 SI D) push  SI ) AX mov               8 SI D) SI lea  Next end-code macro  :ax 0   T&P  restrict Code 2>r  ( d -- )  DX pop  -8 SI D) SI lea  DX 4 SI D) mov          AX SI ) mov  AX pop                                             Next end-code macro  :dx :ax T&P  restrict                 \ @ ! +!  dup  ?dup                                    04nov01py                                                                Code @    ( addr -- n )         AX ) AX mov Next end-code macro                                 :@ :@ T&P                       Code !    ( n addr -- )         AX ) pop  AX pop                                                Next end-code macro :! :ax T&P                                                                  Code +!  ( n addr -- )          DX pop  DX AX ) add  AX pop                                     Next end-code macro :dx :ax T&P                                                                 Code ?dup   ( n -- n n / 0 )                                         AX AX test  0<> IF  AX push  THEN                               Next end-code macro                                        \\ : ?dup ( n -- n n / false) dup IF dup THEN ;                                                                                                                                                 \ c@ c! w@ wextend                                     15aug05pyCode c@   ( addr -- 8b )      .b AX ) AX movzx                                                Next end-code macro :c@ :c@ T&P   Code c!   ( 8b addr -- )      DX pop   DL AX ) mov  AX pop                                    Next end-code macro :c! :ax T&P   code ctoggle   ( 8b addr -- ) DX pop  DL AX ) xor  AX pop                                     Next end-code macro :dx :ax T&P   Code w@   ( addr -- 16b )     AX ) AX movzx Next end-code macro Code wextend   ( 16b -- 32b ) AX AX movsx Next end-code macro   Code w!   ( 16b addr -- )     DX pop DX AX ) .w mov  AX pop                                   Next end-code macro :dx :ax T&P   Code wx@  ( addr -- 16bs )    AX ) AX movsx                                                   Next end-code macro               Code cx@  ( addr -- 8bs )     .b AX ) AX movsx                                                Next end-code macro                                                                               \ port IO, colorForth memops                           15aug05pyCode pc@    ( io -- c )         AX DX mov  AX AX xor  .b in                                     Next end-code macro             Code pc!    ( c io -- )         AX DX mov  AX pop .b out  AX pop                                Next end-code macro :dx> :ax T&P                                                                Code >a  AX OP mov  AX pop   Next end-code macro  0 :ax T&P     Code a>  AX push  OP AX mov  Next end-code  macro  :ax 0 T&P    Code a@+ AX push  OP ) AX mov  cell # OP add  Next end-code              macro :ax 0 T&P                                        Code a!+ AX OP ) mov  cell # OP add  AX pop  Next end-code               macro 0 :ax T&P                                        Code ac@+ AX push  .b OP ) AX movzx  OP inc  Next end-code               macro :ax 0 T&P                                        Code ac!+ AL OP ) mov  OP inc  AX pop  Next end-code                     macro 0 :ax T&P                                        \ @+ !+                                                04nov01py                                                                Code @+ ( addr -- n addr' )                                          AX ) push  4 # AX add  Next end-code macro                 Code !+ ( n addr -- addr' )                                          AX ) pop   4 # AX add  Next end-code macro                 Code w@+ ( addr -- n addr' )  AX ) DX movzx                          2 # AX add  DX push  Next end-code 0 :dx T&P               Code wx@+ ( addr -- n addr' )  AX ) DX movsx                         2 # AX add  DX push  Next end-code 0 :dx T&P               Code w!+ ( n addr -- addr' )  DX pop                                 .w DX AX ) mov  2 # AX add  Next end-code :dx 0 T&P        Code c@+ ( addr -- n addr' )  .b AX ) DX movzx                       AX inc  DX push  Next end-code 0 :dx T&P                   Code c!+ ( n addr -- addr' )  DX pop                                 DL AX ) mov  AX inc  Next end-code :dx 0 T&P               \ over nip under                                       10oct99pyCode over   ( n1 n2 -- n1 n2 n1 )                                    AX push  4 SP D) AX mov   Next end-code macro                   :ax :over T&P                                              Code over2  ( n1 n2 n3 -- n1 n2 n3 n1 )                              AX push  8 SP D) AX mov   Next end-code macro                   :ax :over T&P                                              Code nip    ( n1 n2 -- n2 )                                          cell # SP add  Next end-code macro                         Code under  ( n1 n2 - n2 n1 n2 )                                     DX pop  AX push  DX push                                        Next end-code macro  :dx :dx T&P                           ' under Alias tuck                                              Code swap   ( n1 n2 -- n2 n1 )                                       DX pop  AX push  DX AX mov                                      Next end-code macro  :dx :dx> T&P                          \ double word stack manip.                             18nov01pyCode 2swap   ( 64b1 64b2 -- 64b2 64b1 )                                      DX pop  CX pop  DX SP ) xchg  AX push                           DX push  CX AX mov  Next end-code macro :dx 0 T&P  Code 2dup    ( 64b -- 64b 64b )  SP ) DX mov  AX push  DX push               Next end-code  macro  0 :dx T&P                    Code 2over   ( 64b1 64b2 -- 64b1 64b2 64b1 )                                 AX push  $C SP D) push  $C SP D) AX mov                         Next end-code macro  :ax :over T&P                 : 2rot  2>r 2swap 2r> 2swap ;                                   : D0<  nip 0< ; macro                                           Code depth   ( -- n )  AX push  user' S0 UP D) AX mov                SP AX sub  2 # AX sar  Next end-code                       Code rdepth  ( -- n )  AX push  user' R0 UP D) AX mov                RP AX sub  2 # AX sar  Next end-code                                                                                       \ + - and or xor                                       22jun01py                                                                Code +     ( n1 n2 -- n3 )      DX pop  DX AX add                    Next end-code macro  :+   :+   T&P                         Code under+ ( n1 n2 n3 -- n1+3 n2 )  AX 4 SP D) add  AX pop          Next end-code macro  0    :AX  T&P                         Code -     ( n1 n2 -- n3 )      DX pop  DX AX xchg  DX AX sub        Next end-code macro  :-   :-   T&P                                                                                         Code or    ( n1 n2 -- n3 )      DX pop  DX AX or                     Next end-code macro  :or  :or  T&P                         Code and   ( n1 n2 -- n3 )      DX pop  DX AX and                    Next end-code macro  :and :and T&P                         Code xor   ( n1 n2 -- n3 )      DX pop  DX AX xor                    Next end-code macro  :xor :xor T&P                                                                                         \ not negate                                           18nov01py                                                                Code invert ( n1 -- n2 )        AX not   Next end-code macro                                                                    Code negate ( n1 -- n2 )        AX neg   Next end-code macro                                                                    Code lshift  ( x 1-32 -- x )    AX CX mov  AX pop  AX shl            Next end-code macro                                        Code rshift  ( u 1-32 -- u )    AX CX mov  AX pop  AX shr            Next end-code macro                                        Code >>  ( n 1-32 -- n )        AX CX mov  AX pop  AX sar            Next end-code macro                                        ' lshift alias <<                                                                                                                                                                                                                                               \ dnegate d+ 2@ 2! perform                             18nov01py                                                                Code dnegate   ( d1 -- -d1 )  SP ) neg  0 # AX adc  AX neg           Next end-code macro                                        Code d+        ( d1 d2 -- d3 )                                       DX pop  CX pop  DX SP ) add  CX AX adc                          Next end-code macro :dx 0 T&P                              Code m+        ( d1 m2 -- d3 )                                       cwd  AX 4 SP D) add  AX pop  DX AX adc                          Next end-code macro                                        Code 2@ ( addr -- d )  cell AX D) push  AX ) AX mov                  Next end-code macro  0 :@ T&P                              Code 2! ( d addr -- )  AX ) pop  cell AX D) pop  AX pop              Next end-code macro 0 :ax T&P                                                                                                                                                              \ 1+ 2+ 3+ 4+ 6+ 8+    1- 2- 4-                   mod  22may93py                                                                Code char+ ( n1 -- n2 )  AX inc      Next end-code macro        ' char+ alias 1+                                                Code 2+ ( n1 -- n2 )  2 # AX add  Next end-code macro 0 :q+ T&P Code 3+ ( n1 -- n2 )  3 # AX add  Next end-code macro 0 :q+ T&P Code 4+ ( n1 -- n2 )  4 # AX add  Next end-code macro 0 :q+ T&P ' 4+ alias cell+                                                Code 1- ( n1 -- n2 )  AX dec      Next end-code macro           Code 2- ( n1 -- n2 ) -2 # AX add  Next end-code macro 0 :q+ T&P Code 4- ( n1 -- n2 ) -4 # AX add  Next end-code macro 0 :q+ T&P ' 4- alias cell-                                                Code 6+ ( n1 -- n2 )  6 # AX add  Next end-code macro 0 :q+ T&P Code 8+ ( n1 -- n2 )  8 # AX add  Next end-code macro 0 :q+ T&P                                                                                                                                 \ number Constants                                mod  06apr96py                                                                : 0        ( --  0 )    &0 ;  macro                             : 1        ( --  1 )    &1 ;  macro                             : 2        ( --  2 )    &2 ;  macro                             : 3        ( --  3 )    &3 ;  macro                             : 4        ( --  4 )    &4 ;  macro                             ' 4 alias cell                                                  : -cell    ( -- -4 )   -&4 ;  macro                             : -1       ( -- -1 )   -&1 ;  macro                             : true     ( -- -1 )    -1 ;  macro                             : false    ( --  0 )     0 ;  macro                             code off ( addr -- )    0  # AX ) mov  AX pop                                           Next end-code  macro    0 :ax T&P       code on  ( addr -- )    -1 # AX ) mov  AX pop                                           Next end-code  macro    0 :ax T&P       \ 2* 2/ 4* 4/ pick                                     21may93py                                                                Code 2*  ( n -- 2*n )    AX AX add   Next end-code macro        Code 2/  ( n -- n/2 )    1 # AX sar  Next end-code macro        Code 4*  ( n -- 4*n )    2 # AX sal  Next end-code macro        Code 4/  ( n -- n/4 )    2 # AX sar  Next end-code macro        Code D2* ( d -- d*2 )  DX pop  DX DX add  AX AX adc  DX push         Next end-code macro  :dx :dx T&P                           Code D2/ ( d -- d/2 )  DX pop  1 # AX sar  1 # DX rcr  DX push       Next end-code macro  :dx :dx T&P                           Code pick ( n -- n )     SP AX *4 I) AX mov Next end-code macro ' 4* alias cells                                                ' 4/ alias cell/                                                : chars ; immediate                                             \\                                                              : pick    ( n -- 32b.n )     1+ cells sp@ + @ ;                 \ rot -rot pick roll -roll                             27dec92py                                                                Code rot    ( n1 n2 n3 -- n2 n3 n1 )                                 CX pop  DX pop  CX push  AX push  DX AX mov                     Next end-code macro  0 :dx> T&P                                                                                            Code -rot   ( n1 n2 n3 -- n3 n1 n2 )                                 DX pop  CX pop  AX push  CX push  DX AX mov                     Next end-code macro :dx :dx> T&P                                                                                           : roll   ( n -- )                                                 dup >r  pick sp@ dup cell+  r> 1+ cells move drop ;           : -roll   ( n -- )   >r dup  sp@ dup cell+                        dup cell+ swap  r@ cells move  r> 1+ cells + ! ;              \\                                                              : -rot    ( n1 n2 n3 -- n3 n1 n2 )   rot rot ;                  \ branch ?branch push                                  22mar03py                                                                | Code branch   0 rel) jmp  0 here 4- !  Next end-code macro                                                                    | Code ?branch   ( flag -- )                                           AX AX test  AX pop  0 0= jmpIF   0 here 4- !                    Next end-code macro  :f 0 T&P                                                                                            | code call ( -- )  r: 0 rel) call  0 here 4- !                        Next end-code macro :r :r T&P                                                                                            Label pull             :R CX pop  DX pop  DX CX ) mov  ret  T   Code push  ( addr -- ) R: AX ) DX mov   DX push   AX push                              pull A# push  S: AX pop                                         Next end-code  macro restrict :r :ax T&P                                                                 \ comparision code words                               20feb94py                                                                Code 0<>   ( n -- flag )      AX AX test   0<> makeflag                    Next end-code macro :? :f T&P                        Code 0=    ( n -- flag )      AX AX test   0=  makeflag                    Next end-code macro :f :f T&P                                                                                        Code 0<    ( n -- flag )      AX AX test   0<  makeflag                    Next end-code macro :? :f T&P                        \ Code 0<  ( n -- flag )      CWD  DX AX mov                    \                             Next end-code macro 0 :dx> T&P    Code 0>    ( n -- flag )      AX AX test   >   makeflag                    Next end-code macro 0  :f T&P                        Code ?exit ( flag -- )                                               AX AX test  AX pop  0<> IF  Next  THEN  :S                      Next end-code restrict macro :f 0 T&P                      \ comparision words                                    10jul96pyCode >     ( n1 n2 -- flag )  DX pop   AX DX cmp  >  makeflag              Next end-code macro :cdx :f T&P                      Code <     ( n1 n2 -- flag )  DX pop   AX DX cmp  <  makeflag              Next end-code macro :cdx :f T&P                      Code u>    ( u1 u2 -- flag )  DX pop   AX DX cmp  u> makeflag              Next end-code macro :cdx :f T&P                      Code u<    ( u1 u2 -- flag )  DX pop   AX DX cmp  u< makeflag              Next end-code macro :cdx :f T&P                      Code =     ( n1 n2 -- flag )  DX pop   AX DX cmp  0= makeflag              Next end-code macro :cdx :f T&P                      : 0>=      0< 0= ; macro        : 0<=      0> 0= ; macro        : <=       >  0= ; macro        : >=       <  0= ; macro        : u<=      u> 0= ; macro        : u>=      u< 0= ; macro        : <>       =  0= ; macro                                        : d0=      ( d -- flag )  or 0= ;  macro                        \ comparision words                                    14jul96pyCode d-        ( d1 d2 -- d3 )                                       DX pop  CX pop  DX SP ) sub   AX CX sbb   CX AX mov             Next end-code macro :dx 0 T&P                              Code within  ( u1 [low up[ -- flag )  DX pop  CX pop                 DX AX sub   DX CX sub   CX AX cmp   u> makeflag                 Next end-code macro  :dx :f T&P                            Code d=        ( d1 d2 -- flag )                                     DX pop  CX pop  CX AX xor  CX pop  DX CX xor  CX AX or          0= makeflag  Next end-code macro :dx :f T&P                Code d<        ( d1 d2 -- f )                                        DX pop  CX pop  DX SP ) sub   AX CX sbb   DX pop                < makeflag  Next end-code macro :dx :f T&P                 Code du<       ( d1 d2 -- f )                                        DX pop  CX pop  DX SP ) sub   AX CX sbb   DX pop                u< makeflag  Next end-code macro :dx :f T&P                \ min max umax umin extend dabs abs                    28may00py                                                                : min      ( n1 n2 -- n3 )    2dup  >  IF nip exit THEN drop ;  : max      ( n1 n2 -- n3 )    2dup  <  IF nip exit THEN drop ;  : umax     ( u1 u2 -- u3 )    2dup u<  IF nip exit THEN drop ;  : umin     ( u1 u2 -- u3 )    2dup u>  IF nip exit THEN drop ;  Code extend   ( n -- d )  CWD  AX push  DX AX mov  Next              end-code macro  0 :dx> T&P                                 ' extend Alias S>D                                              Code dabs  ( d -- ud )  AX AX test                                   0< IF  SP ) neg  0 # AX adc  AX neg  THEN                       Next end-code macro 0 0 T&P                                Code abs   ( n -- u )   AX AX test                                   0< IF  AX neg  THEN  Next end-code macro  0 0 T&P          Code bounds ( start count -- limit start )  DX pop  DX AX add        AX push  DX AX mov  Next end-code macro :dx :dx> T&P       \ um/mod m/mod m/rem                                   29jan05pyCode */mod  ( n1 n2 n3 -- rem quot )  AX CX mov  AX pop  DX pop      DX AX imul  AHEAD  end-code                                Code /mod     ( n1 n2 -- mod qout )  AX CX mov  AX pop  cwd          AHEAD  end-code                                            Code m/mod    ( d n -- mod quot )  AX CX mov  DX pop  AX pop         THEN  THEN   BX push  CX BX mov  DX BX xor                      $1F # BX sar  CX idiv                                           DX BX and   BX 0<> setIF  1 # BX and  BX AX sub                 BX neg  CX BX and  BX DX add                                    BX pop  DX push  Next end-code                             Code mu/mod   ( d u -- mod quot )  AX CX mov  DX pop  DX AX mov      $1F # AX sar  CX AX and  AX DX add  AX pop                      CX div  DX push  Next end-code  macro 0 :dx T&P            Code um/mod   ( d n -- rem quot )  AX CX mov  DX pop  AX pop         CX div  DX push  Next end-code  macro 0 :dx T&P            \ um/mod m/mod m/rem                                   29jan05pyCode */  ( n1 n2 n3 -- quot )  AX CX mov  AX pop  DX pop             DX AX imul  AHEAD  end-code                                Code /     ( n1 n2 -- qout )  AX CX mov  AX pop  cwd                 AHEAD  end-code                                            Code m/    ( d n -- quot )  AX CX mov  DX pop  AX pop                THEN  THEN   BX push  CX BX mov  DX BX xor                      $1F # BX sar  CX idiv                                           DX BX and   BX 0<> setIF  1 # BX and  BX AX sub                 BX pop  Next end-code                                                                                                      Code mu/   ( d u -- quot )  AX CX mov  DX pop  DX AX mov             $1F # AX sar  CX AX and  AX DX add  AX pop                      CX div  Next end-code            macro 0 0 T&P             Code m/rem    ( d n -- rem quot )  AX CX mov  DX pop  AX pop         CX idiv  DX push  Next end-code  macro 0 :dx T&P           \ /mod / mod */mod */ u/mod  ud/mod  * d*              23jan07py                                                                ' m/mod Alias fm/mod            ' m/rem Alias sm/rem                                                                            : mod    ( n1 n2 -- rem )           /mod drop ;                 : u/mod  ( u1 u2 -- urem uquot )    >r 0 r> um/mod ;            : ud/mod ( ud1 u2 -- urem udquot )  >r 0 r@ um/mod r> swap >r                                       um/mod r> ;                 : d*     ( ud1 ud2 -- udprod )      >r swap >r 2dup um*                                             2swap r> * swap r> * + + ;  : m*/    ( d1 n2 u3 -- dqout )    >r extend >r abs -rot           extend r> xor r> swap >r >r dabs rot under um* 2swap um*        swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod -rot              r> IF IF 1. d+ THEN dnegate ELSE drop THEN ;                  : Dmax  2over 2over d<     IF  2swap  THEN  2drop ;             : Dmin  2over 2over d< 0=  IF  2swap  THEN  2drop ;             \ q/ qmod q/mod q* q*/                                 27sep99pyCode um*   ( u1 u2 -- ud )  DX pop  DX mul                           AX push  DX AX mov  Next end-code macro :dx :dx> T&P       Code m* ( n1 n2 -- d )  DX pop  DX AX imul                           AX push  DX AX mov  Next end-code macro :dx :dx> T&P       Code q/    ( n1 n2 -- quot )  AX CX mov  AX pop  cwd  CX idiv        Next end-code macro                                        Code q/mod   ( n1 n2 -- rem quot )                                   AX CX mov  AX pop  cwd  CX idiv  DX push                        Next end-code macro  0 :dx T&P                             Code qmod   ( n1 n2 -- rem )  AX CX mov  AX pop  cwd                 CX idiv  DX AX mov   Next end-code macro  0 :dx> T&P       code q*  ( n1 n2 -- n3 )  DX pop   DX mul                            Next end-code macro   :dx 0 T&P            ' q* Alias *    Code q*/ ( n1 n2 n3 -- quot )  AX CX mov  AX pop  DX pop             DX AX imul  CX idiv  Next end-code macro                   \ initializing a loop                                  21jun01pyCode  (do   ( limit start -- )                                        R: DX pop  loopreg push  AX loopreg mov                         lods  $80000000 # AX add  AX push  looplim loopreg sub          lods  DX jmp   end-code  restrict                                                                                         Code  (?do  ( limit start -- )                                        R: DX pop  loopreg push  AX loopreg mov                         lods  AX loopreg cmp  $80000000 AX D) AX lea  AX push           0= IF  lods  DX jmp  THEN  looplim loopreg sub                  S: AX pop  7 # DX add  DX jmp   end-code  restrict        Code  (u-do  ( limit start -- )                                       R: DX pop  loopreg push  AX loopreg mov                         lods  AX loopreg cmp  $80000000 AX D) AX lea  AX push           u<= IF  lods  DX jmp  THEN  looplim loopreg sub                 S: AX pop  7 # DX add  DX jmp   end-code  restrict        \ further conditional loop entries                     21jun01pyCode  (+do  ( limit start -- )                                        R: DX pop  loopreg push  AX loopreg mov                         lods  AX loopreg cmp  $80000000 AX D) AX lea  AX push           >= IF  lods  DX jmp  THEN  looplim loopreg sub                  S: AX pop  7 # DX add  DX jmp   end-code  restrict        Code  (u+do  ( limit start -- )                                       R: DX pop  loopreg push  AX loopreg mov                         lods  AX loopreg cmp  $80000000 AX D) AX lea  AX push           u>= IF  lods  DX jmp  THEN  looplim loopreg sub                 S: AX pop  7 # DX add  DX jmp   end-code  restrict        Code  (-do  ( limit start -- )                                        R: DX pop  loopreg push  AX loopreg mov                         lods  AX loopreg cmp  $80000000 AX D) AX lea  AX push           <= IF  lods  DX jmp  THEN  looplim loopreg sub                  S: AX pop  7 # DX add  DX jmp   end-code  restrict        \ Counting and leaving a loop                          20jun01py                                                                Code I   ( -- n )  AX push  looplim AX mov   loopreg AX add          Next  end-code  macro   restrict   :ax :i T&P              Code J   ( -- n )  AX push  4 RP D) AX mov   8 RP D) AX add          Next  end-code  macro   restrict   :ax 0 T&P               Code K   ( -- n )  AX push  $C RP D) AX mov  $10 RP D) AX add        Next  end-code  macro   restrict   :ax 0 T&P               Code I'  ( -- l )  AX push looplim AX mov  $80000000 # AX add        Next  end-code  macro   restrict   :ax 0 T&P               Code J'  ( -- l )  AX push 8 RP D) AX mov  $80000000 # AX add        Next  end-code  macro   restrict   :ax 0 T&P               Code K'  ( -- l )  AX push $10 RP D) AX mov $80000000 # AX add       Next  end-code  macro   restrict   :ax 0 T&P               Code I@  ( -- n )      AX push     loopreg AX mov                    Next  end-code  macro   restrict   :ax 0 T&P               \ compiling Loops                                      28dec02pyCode (+loop   AX loopreg add  AX pop  0 vc jmpIF  here 4- off        Next  end-code  macro restrict  :+loop 0 T&P               Code (-loop   AX neg  AX loopreg add  loopreg AX add  AX pop         0 vc jmpIF  here 4- off  Next  end-code  macro restrict    Code (loop   loopreg inc  0 vc jmpIF  here 4- off                    Next  end-code  macro restrict                             Code (next   loopreg dec  0 0>= jmpIF  here 4- off                   Next  end-code  macro restrict                             Code +i'   AX looplim add  AX loopreg sub  vs makeflag               Next end-code  macro restrict 0 :f T&P                     code unloop    ( -- )          \ terminate a DO..LOOP                cell RP D) loopreg mov  2 cells # RP add  \  looplim pop        Next end-code  macro restrict                              Code Ith ( addr -- data )  looplim DX mov   loopreg DX add           AX DX *4 I) AX mov   Next  end-code  macro   restrict      \ cmove cmove>                                         20jun01py                                                                Code cmove    ( from to count -- )  DX pop  CX pop                   R: SI push  DI push  CX SI mov  DX DI mov                  Label (cmove   AX CX mov                                             rep .b movs  DI pop  SI pop  lods  Next end-code           Code cmove>   ( from to count -- )  DX pop  CX pop                   R: SI push  DI push  CX SI mov  DX DI mov                  Label (cmove>   std   AX dec   AX SI add   AX DI add   AX inc        AX CX mov  rep .b movs  cld                                     DI pop  SI pop  lods  Next end-code                                                                                        Code  (for  (       start -- )                                        R: DX pop  loopreg push  AX loopreg mov                         0 # push  lods  DX jmp   end-code  restrict               \     saves old "index" and modified "limit" on stack           \ move                                                 09dec01py                                                                Code move     ( from to count -- )                                   DX pop  CX pop  CX DX cmp R: 0<> IF  SI push  DI push                u< IF  CX SI mov  DX DI mov                                            AX CX mov  3 # CX and  .b rep movs                       ELSE   std  -1 AX CX DI) SI lea  -1 AX DX DI) DI lea                   AX CX mov  3 # CX and  .b rep movs                              -3 # SI add  -3 # DI add                                 THEN   AX CX mov  2 # CX shr  rep movs  cld                     DI pop  SI pop  THEN                                       lods  Next end-code                                                                                                                                                                                                                                                                                                        \ place count /string                                  03sep09py: place  ( addr len to -- ) over >r  rot over 1+  r> move c! ;  Code count ( addr -- addr+1 len )                                    AX inc  AX push  .b -1 AX D) AX movzx                           Next  end-code  macro                                      Code /string ( addr0 len0 n -- addr1 len1 )                          CX pop  DX pop  AX DX add  AX AX test 0>= IF  AX CX sub               u< IF  CX DX add  CX CX xor  THEN                         ELSE  AX CX sub u>= IF  CX DX add  DX inc -1 # CX mov  THEN     THEN  DX push  CX AX mov  Next end-code                    Code -text   ( addr1 len addr2 -- n )  CX pop  DX pop                CX CX test  0= IF  CX AX mov  Next  THEN                        SI push  DI push  AX DI mov  DX SI mov                          repe .b cmps                                                    .b -1 SI D) AX movzx   .b -1 DI D) DX movzx  DX AX sub          DI pop  SI pop  Next end-code                              \ fill erase                                           09dec01py                                                                Code fill   ( addr quan 8b -- )                                      AL AH mov  .w AX DX mov   $10 # AX sal  .w DX AX mov            CX pop  DI DX mov  DI pop                                       1 # CX shr  u< IF  .b stos  THEN                                1 # CX shr  u< IF  .w stos  THEN                                rep stos  DX DI mov  AX pop  Next end-code                                                                                 : erase   ( addr quan -- )            0 fill ;                                                                                  | Code (defer  R: 0 UP L) call -4 allot                                Next end-code macro :r :r T&P                            | Code (patch  R: 0 A# DX mov  DX jmp                                  Next end-code macro :r :r T&P                                                                                            \ here pad allot , c, w,                               17jun10py                                                                : here   ( -- addr )  dp @ ; macro                              : unused ( -- u )  thismodule @ dup cell+ @ + here - $120 - ;   Code allot  ( n -- )  AX user' dp UP D) add  AX pop                  Next end-code macro 0 :ax T&P                              : aligned  ( addr -- addr1 )    3 + -4 and ; macro              : align    here dup 3 + -4 and swap ?DO bl c, LOOP ;            : pad    ( -- addr )             here $CC + 3 + -4 and ;        Code ,  ( n -- )  user' dp UP D) DX mov  AX DX ) mov                 4 # user' dp UP D) add  AX pop  Next end-code              : 2,  , , ;                                                     Code c, ( n -- )  user' dp UP D) DX mov  AL DX ) mov                 1 # user' dp UP D) add  AX pop  Next end-code              Code w, ( n -- )  user' dp UP D) DX mov  .w AX DX ) mov              2 # user' dp UP D) add  AX pop  Next end-code              \ +Bit -Bit ~Bit Bit@  Relinfo  A! V! A,               04feb93py                                                                Code +Bit  ( addr pos -- )  DX pop                                   AX DX ) bts  AX pop  Next end-code macro  :dx :ax T&P      Code -Bit  ( addr pos -- )  DX pop                                   AX DX ) btr  AX pop  Next end-code macro  :dx :ax T&P      Code ~Bit  ( addr pos -- )  DX pop                                   AX DX ) btc  AX pop  Next end-code macro  :dx :ax T&P      Code Bit@  ( addr pos -- flag )  DX pop  AX DX ) bt  b makeflag      Next end-code macro  :dx :f  T&P                           : Relinfo  thisModule @ dup cell+ @ + ;                         : relon   Relinfo swap >rel +Bit ;                              : reloff  Relinfo swap >rel -Bit ;                              : A! ( addr addr -- )  dup relon ! ;                            : V! ( n addr -- )  dup reloff ! ;                              : A, ( addr -- ) here relon , ;                                 \\ movebits                                            26sep92pyCode movebits ( B$s B$z start ziel len -- ) SP )+ $0307 # movem      D2 D3 move   4 # D3 asr   D3 D3 add   D3 A1 adda                D1 D4 move   4 # D4 asr   D4 D4 add   D4 A0 adda                D1 D0 add   D0 D3 move   4 # D3 asr   D3 D3 add   D4 D3 sub     1 # D3 asr  $F D4 moveq   D4 D2 and   D4 D1 and   D1 D2 sub     0< IF 2 A1 subq THEN D4 D0 and D4 D2 sub  D2 neg  D4 D2 and     1 D2 addq  -1 D4 moveq  .w D4 clr   .l D0 D4 asr   D4 swap      .w D1 D4 lsr   1 D3 subq   0< IF   D4 D3 move   D4 swap         D4 D3 and   0 D4 moveq   D3 D4 move   0 D3 moveq  THEN          .l A1 ) D0 move   2 A1 addq   D2 D0 lsr   .w D4 D0 and          D4 not   D4 A0 ) and   D0 A0 )+ or                              AHEAD BEGIN BUT  lods  AX DX shld  DX AX xchg  stos                         THEN  BX dec  u< UNTIL                              D4 swap   .l A1 ) D0 move   D2 D0 lsr   .w D4 D0 and            D4 not   D4 A0 ) and   D0 A0 ) or   Next end-code          \ erasebits                                            28dec92py: movebits ( B$s B$z s z # -- ) >r 2dup > IF  rot swap r>          0 ?DO 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN 1+ LOOP  ELSE  rot swap r@ + r> ?dup IF 1-                                  FOR 1- 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN NEXT     THEN  THEN  2drop 2drop ;                                  : erasebits ( B$ s # -- ) 0 ?DO  2dup -bit 1+  LOOP  2drop ;    \\ Code erasebits ( B$addr start len -- )   SP )+ $0103 # movem      D1 D2 move   5 # D2 asr   2 # D2 lsl   D2 A0 adda               $1F D3 moveq   D1 D3 and   -1 D4 moveq   D3 D4 lsr              D1 D0 add   D0 D1 move   5 # D1 asr   2 # D1 lsl                D2 D1 sub   $1F D3 moveq   D3 D0 and   -1 D3 moveq              D0 D3 lsr   D3 not   2 # D1 asr   1 D1 subq                     0< IF   D4 D3 and   D3 not   D3 A0 ) and   Next   THEN          D4 not   D4 A0 )+ and                                           ax ax xor  rep stos   D3 not   D3 A0 ) and   Next end-code \ skip scan                                            29may05py                                                                Code skip    ( addr len del -- addr1 len1 )  CX pop                  ?DO  drop  DI DX mov  DI pop                                         repe .b scas  0<> IF  DI dec  CX inc  THEN                      DI push  DX DI mov  THEN  CX AX mov  Next  end-code   Code scan    ( addr len chr -- addr1 len1 )  CX pop                  ?DO  drop  DI DX mov  DI pop                                         rep  .b scas  0=  IF  DI dec  CX inc  THEN                      DI push  DX DI mov  THEN  CX AX mov  Next  end-code                                                                   Code skip<   ( addr len chr -- addr1 len1 )  CX pop                  ?DO  drop  DI DX mov  DI pop                                         BEGIN  AL DI ) cmp  u<= WHILE  DI inc  CX dec 0= UNTIL          ( ELSE  CX dec  DI inc )  THEN                                  DI push  DX DI mov  THEN  CX AX mov  Next  end-code   \ -skip -scan                                          29may05py                                                                Code -skip   ( addr len del -- addr1 len1 )   CX pop                 ?DO drop  DI DX mov  DI pop  DI push  CX DI add  DI dec             std  repe .b scas  cld  0<> IF  DI inc  CX inc  THEN            DX DI mov  THEN  CX AX mov   Next  end-code            Code -scan   ( addr len chr -- addr1 len1 )   CX pop                 ?DO drop  DI DX mov  DI pop  DI push  CX DI add  DI dec             std  rep  .b scas  cld  0=  IF  DI inc  CX inc  THEN            DX DI mov  THEN  CX AX mov  Next  end-code                                                                             Code scan<   ( addr len chr -- addr1 len1 )  CX pop                  ?DO  drop  DI DX mov  DI pop                                         BEGIN  AL DI ) cmp  u> WHILE  DI inc  CX dec 0= UNTIL           ( ELSE  CX dec  DI inc )  THEN                                  DI push  DX DI mov  THEN  CX AX mov  Next  end-code   \ convert to upper case                                12jun97py[IFDEF] :GO32                                                   Label upper                                     Ascii a   parse 
	

 !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~���A����EEEIII�����O�OUUY�������AIOU��AO��������������������������������������������������������AB�����������������������������a     T here $100 allot swap cmove                                                                                              Label lower                                     Ascii A   parse 
	

 !"#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklmnopqrstuvwxyz{|}~뇁������������������������������������������������������������������������������������������������������������������������������A     T here $100 allot swap cmove                                                                                              \ convert to upper case                                16jan05py[ELSE]                                                          Label upper                                     Ascii a   parse 
	

 !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~a     T here $80 allot swap cmove                               $100 $80 [DO] [I] c, [LOOP]                                                                                                     Label lower                                     Ascii A   parse 
	

 !"#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklmnopqrstuvwxyz{|}~�A     T here $80 allot swap cmove                               $100 $80 [DO] [I] c, [LOOP]                                     [THEN]                                                                                                                                                                                          \ capital capitalize                                   06apr96py                                                                : capital ( char -- char' ) upper + c@ ; macro                  : tolower ( char -- char' ) lower + c@ ; macro                                                                                  Code capitalize ( string -- string )  upper A# DX mov                AX push  DI push  AX DI mov  AX AX xor                          .b DI ) CX movzx  DI inc                                        ?DO  DI ) AL mov  AX DX I) AL mov  .b stos  LOOP  THEN          DI pop  AX pop  Next end-code                                                                                                                                                              \\                                                              : capitalize ( string -- string)                                 dup count bounds ?DO  I c@  capital  I c!  LOOP ;                                                                              \ (word                                                26mar93pyCode (word ( char addr0 len0 -- addr )  AX CX mov DX pop AX pop      SI push DI push DX push  DX SI mov  user' >in UP D) DX mov      user' dp UP D) DI mov  DX SI add  DX CX sub  0 # DX mov         >  IF  AL $20 # cmp                                                    0= IF  BEGIN  AL SI ) cmp  u<= WHILE  SI inc  CX dec                   0= UNTIL  ELSE  CX dec  SI inc  THEN                     ELSE   DI SI xchg  repe .b scas  DI SI xchg  THEN           0<> IF  SI dec  DI DX mov  DI inc  CX inc  AL $20 # cmp             0= IF DO  AL SI ) cmp  .b movs  u> WHILE  LOOP                        ELSE  CX CX xor  THEN                                     ELSE  DO  AL SI ) cmp  .b movs  LOOPNE  THEN                    0= IF  DI dec  THEN  .b $20 # DI ) mov                          DI DX xchg  DI DX sub  DX dec  THEN                      THEN  DL DI ) mov  DI AX mov  DX pop  DX SI sub                 SI user' >in UP D) mov  DI pop  SI pop  Next end-code      \ b/blk aligned source word parse name                 29may05py                                                                $400 Value b/blk                0 Value blk+                                                                                    : source   ( -- addr len )   blk @  dup                           IF  loadfile @ (block b/blk exit  THEN  drop tib #tib @ ;                                                                     : word     ( char -- addr )       source (word ;                : parse    ( char -- addr len )                                   >r  source  >in @ /string  over  swap r>  scan >r               over - dup r> IF 1+ THEN  >in +! ;                            : parse-name    ( -- addr len )                                   source  >in @ /string bl skip<  over swap  bl scan< >r          over - source nip r> 1- 0 max - >in ! ;                       : (name    ( -- addr )            bl word ( capitalize) ;       Defer name      ' (name IS name                                 \ Makro modifikation                                   20jun01py                                                                User lastdes                    AUser lastopt   NIL lastopt !   AUser last       0 last !       AUser lastcfa    0 lastcfa !    : lastxt ( -- xt )  lastcfa @ ;                                 | Code >T&P  DX pop  DL AH mov  Next end-code                                                                                   \ | : >T&P  $FF and >r $FF and $100 Q* r> or ;                                                                                  | : (T&P ( takemode pushmode -- )                                   >T&P lastdes w! ;                                           : T&P ( takemode pushmode -- )                                    state @ IF  compile (T&P exit THEN                              >T&P lastopt @ w! ;           immediate                                                                                       $100 load       \ load opttab                                   \ words for number literals                            12mar00py                                                                |   $E8 Constant [call]         |   $C3 Constant [ret]          | $F487 Constant [s~r]                                          | : S:  ( -- )  lastdes c@ dup :r =                                 IF   drop [s~r] w,                                              ELSE :s = 0= IF  -2 allot  THEN  THEN  0 lastdes c! ;       | : R:  ( addr1 count1 T&P -- addr2 count2 skip T&P )               dup $FF and :r = 0=  IF  dup 8 >> :r = 0=                       IF  -2 allot 2  ELSE  0  THEN  ELSE  0  THEN swap ;         : Literal  ( n --) compile lit here 6 -  ! ; immediate restrict : 2Literal  swap compile Literal compile Literal ;                                                           immediate restrict : ALiteral ( n --) compile lit here 6 - A! ; immediate restrict : ?lit,   state @ 0= ?exit  compile  Literal ;                  : ?alit,  state @ 0= ?exit  compile ALiteral ;                  \ compiler for Create, Variable and Constant           01jan98py                                                                | : <move> ( size +- -- ) dup $80 and IF  $FFFFFF00 or  THEN        dup 0= IF  2drop exit  THEN  >r here dup r@ abs +               r> 0< IF  swap  THEN  2dup 4 pick 1+ move  >rel >r              >rel relinfo dup 2swap 2- r> 2- rot 2+ movebits ;           | : (opt, ( addr -- )  0 here ! dup 3+ c@ dup negate allot          here lastcfa @ 2+ = IF  over c@ lastdes 3+ c!  THEN             over 2+ c@ <move>  dup 5 + count bounds                         ?DO  i c@ dup  IF  c,  ELSE  drop 1 allot  THEN  LOOP           c@ dup IF lastdes c@ IF 0 swap T&P exit THEN THEN drop ;                                                                    | : macro, ( addr count skip -- ) dup >r /string                    dup 0= IF rdrop 2drop exit THEN                                 2dup here swap move under + 3+                                  relinfo r> here >rel 4 pick  movebits allot ;               \ opt,                                                 04feb93py                                                                | : flag>  -7 allot                                                 2 + here 1+ dup 1+ >r c@ $94 xor >r macro,                      r> r> dup c@ $84 = 0= +  ctoggle ;                          | : opt, ( addr len skip Push&Take -- )                             $0505 case? IF  flag> exit  THEN                                dup 8 >>  opttab #opt bounds                                    DO  dup I c@ =                                                      IF  drop $FF and dup dup $60 < IF $F and THEN I 1+ count        bounds  DO  I c@ IF over ELSE dup THEN I 1+ c@ =                            IF  2drop  I (opt,  I 4+ c@ + macro,                                unloop unloop exit  THEN                                    I 5 + c@ 6 +  +LOOP  LEAVE  THEN                    I 1+ c@ 2+  +LOOP drop                                      drop macro, ;                                               \ cfa,                                                 21may93pyCode !lastdes  ( -- )  user' lastdes dup UP D) CL mov                CL over 2+ UP D) mov  .w $80 # UP D) mov  Next end-code    Defer 'cfa,     ' noop IS 'cfa, \ may be patched later          : cfa, ( cfa -- )  'cfa,                                          dup cfa@  dup  [ Label (create? T 0 ] ALiteral =                IF  drop  execute compile ALiteral      exit  THEN                             [ Label (value?  T 0 ] ALiteral =                IF  >body   compile ALiteral compile @  exit  THEN  !lastdes    dup 2- wx@ dup 0< 0=  IF  drop call, exit  THEN                 negate  2dup + w@ lastdes w!                                    here lastcfa @ = IF  lastdes 1+ c@ lastdes 3+ c!  THEN          1- lastdes 1+ w@ R:                                             dup $0F00 and IF dup $000F and IF  opt, exit  THEN THEN         drop macro, ;                                                 ' cfa, Alias compile,                                           \ compile                                              01sep12py                                                                User rel        -1 rel !                                        | : rel?  dup here thisModule @ within rel @ and ;              | : call!  ( cfa addr -- )  under 4+ - swap ! ;                 | : call,  ( cfa -- )  [call] c,  rel?                              IF  here relon  here 1+ relon  THEN  here - 4- ,  ;         : (compile    r> dup @  cfa, cell+ >r ;  restrict               : compile     name find  dup >r  0= no.extensions  r>                         0> IF  cfa,  ELSE  compile (compile A,  THEN ;      immediate restrict                                            : [compile]   ' cfa, ; immediate restrict                       ' compile alias postpone  immediate restrict                    : [[ ; \ token for end of bulk-postponing                       : ]] BEGIN  >in @ ' ['] [[ <> WHILE >in ! compile compile            REPEAT drop ; immediate                                    \ resolve loops and branches   case?                   12apr93py                                                                : ?struc      ( flag -- )       IF  -&22 throw  THEN ;          | : sys?      ( sys -- )        dup 0= ?struc ;                 | : >mark     ( -- sys )        here 6 - ;                      | : >resolve  ( sys -- )        >r here r@ - cell- r> ! ;       | : <resolve  ( sys -- )        here 2- - here 6 - ! ;                                                                          Code case? ( n1 n2 -- n1 false / true )                              DX pop  DX AX sub  0<> IF  DX push  -1 # AX mov  THEN           AX not  Next  end-code                                                                                                     : .align  ( -- )  here 3 and                                      3 case?  IF  $90 c,         exit  THEN                          2 case?  IF  $ED8B w,       exit  THEN                          1 =      IF  $6D8D w, 0 c,  exit  THEN ;                      \ leaving Loops                                        28may00py: BUT       sys? swap ;                      immediate restrict : YET       sys? dup ;                       immediate restrict ' pick alias cs-pick                                            ' roll alias cs-roll                                            User leavings                                                   : DONE   ( addr -- )  S: leavings @                               BEGIN  2dup u<  WHILE  dup @ dup 0<>                                   IF  over + cell+  THEN  swap >resolve  REPEAT            leavings ! drop [s~r] w, ;                 immediate restrict                                                                 | : (leave  here 6 - leavings @                                             dup IF  <resolve  ELSE  over !  THEN  leavings ! ;  : LEAVE     compile branch  (leave  ;        immediate restrict : ?LEAVE    compile 0=  compile ?branch (leave  ;                                                            immediate restrict \ Branching                                            20jun01py: AHEAD     compile branch >mark ;           immediate restrict : IF        compile ?branch >mark ;          immediate restrict : THEN      sys? dup @ ?struc S: >resolve [s~r] w, ;                                                         immediate restrict ' THEN Alias ENDIF                           immediate restrict : ELSE      sys? compile AHEAD swap compile THEN ;                                                           immediate restrict : BEGIN     S: .align here [s~r] w, ;        immediate restrict : WHILE     sys? compile IF swap ;           immediate restrict : AGAIN     sys? compile branch <resolve ;   immediate restrict : UNTIL     sys? compile ?branch <resolve ;  immediate restrict : REPEAT    over 0= ?struc compile AGAIN compile THEN ;                                                      immediate restrict : MEANWHILE compile AHEAD compile BEGIN swap ;                                                               immediate restrict \ ?DO and co                                           20jun01py                                                                : DO        compile (do    compile BEGIN ;   immediate restrict : ?DO       compile (?do   compile LEAVE  compile BEGIN ;                                                    immediate restrict : +DO       compile (+do   compile LEAVE  compile BEGIN ;                                                    immediate restrict : U+DO      compile (u+do  compile LEAVE  compile BEGIN ;                                                    immediate restrict : -DO       compile (-do   compile LEAVE  compile BEGIN ;                                                    immediate restrict : U-DO      compile (u-do  compile LEAVE  compile BEGIN ;                                                    immediate restrict                                                                                                                                                                                                 \ (+loop (loop  LOOP +LOOP                             20jun01py                                                                : FOR       compile (for  compile BEGIN ;    immediate restrict | : loop]   compile DONE compile unloop ;                       | : iter,   ( addr cfa -- addr' )  cfa,  dup <resolve 8 - ;     : ITERATE   sys? ['] (loop  iter, ;          immediate restrict : +ITERATE  sys? ['] (+loop iter, ;          immediate restrict : -ITERATE  sys? ['] (-loop iter, ;          immediate restrict : NEXTITER  sys? ['] (next  iter, ;          immediate restrict : LOOP      compile ITERATE  loop] ;         immediate restrict : +LOOP     compile +ITERATE loop] ;         immediate restrict : -LOOP     compile -ITERATE loop] ;         immediate restrict : NEXT      compile NEXTITER loop] ;         immediate restrict                                                                                                                                                                                                 \ Eaker's case                                         27dec10py                                                                : CASE  compile BEGIN ;                      immediate restrict : OF  compile over compile = compile IF compile drop ;                                                       immediate restrict : ENDOF   compile LEAVE compile THEN ;       immediate restrict : ENDCASE  compile drop ( ! ) compile DONE ; immediate restrict                                                                 : FORK  compile call >mark 2+ ;              immediate restrict : JOIN  sys? dup @ ?struc >resolve compile noop ;                                                            immediate restrict                                                                                                                                                                                                                                                                                                                                 \ state Ascii ,"  (C" (S" C" S"                        09aug07py: hex      $10 base ! ;                                         : decimal  &10 base ! ;                                         : char    ( -- n )  bl word char+ char@ nip ;                   : [char]  ( -- n )  char ?lit, ;  immediate restrict            ' [char] Alias Ascii immediate                                  : ctrl    ( -- n )  char capital $40 xor ?lit, ;                                                            immediate           User cstring+                                                   User sstring+                                                   | : cstringbuf ( n -- n addr )  $FF min  s^ @                       over cstring+ @ tuck + $FF and cstring+ ! + ;               | : >cstringbuf  cstringbuf dup >r place r> ;                   | : sstringbuf ( n -- n addr )  s^ @ $100 +                         over sstring+ @ tuck + $FF and sstring+ ! + ;               | : >sstringbuf  sstringbuf  over >r dup >r swap move r> r> ;   \ "lit ," (C" C" (S" SLiteral                          17jun10py                                                                Code "lit  ( -- addr )  AX push  R:  DX pop  AX pop                  .b AX ) CX movzx  CX inc  AX CX add  CX push                    DX jmp  end-code                                  restrict                                                                 : ,"       '" parse  here over 1+ allot  place ;                : (C"      "lit ;                                      restrict : C"       state @ IF    compile (C" ,"                           ELSE  Ascii " parse  >cstringbuf  THEN ; immediate            : (S"      "lit count ;                                restrict : SLiteral compile (S"  here over 1+ allot place ;                                                           immediate restrict : S"       '" parse  state @ IF  compile SLiteral                 ELSE  >sstringbuf  THEN ;                  immediate          ' C" alias "                                 immediate          \ ." ( .( \ \\ hex decimal                        mod  17jun10py: ,'       '' parse  here over 1+ allot  place ;                : S'       '' parse  state @ IF  compile SLiteral                 ELSE  >sstringbuf  THEN ;                  immediate          : C'       state @ IF    compile (C" ,'                           ELSE  '' parse  >cstringbuf  THEN ; immediate                 : (."      "lit count type ;                           restrict : ."       state @  IF    compile (." ,"                                            ELSE  '" parse type  THEN  ;  immediate     : .'       state @  IF    compile (." ,'                                            ELSE  '' parse type  THEN  ;  immediate     : (        ') parse 2drop ;                       immediate     : .(       ') parse type ;                        immediate     : \        >in @ c/l / 1+ c/l * >in ! ;           immediate     : \\       b/blk >in ! ;                          immediate     : \needs   name find nip IF  compile \  THEN ;                  \ reveal immediate restrict                            14aug13py                                                                Patch 'reveal   ' 2drop IS 'reveal                              | : last?   ( -- false / acf true )    last @ ?dup ;            : reveal ( -- ) last?  IF  dup cell- @ 0<                         IF  dup current @ 'reveal cell- current @ @ over !                  current @ !  ELSE  drop  THEN THEN ;                      : Recursive     reveal ;                     immediate restrict : recurse  lastcfa @ cfa, ;                  immediate restrict : flag! ( 8b --) last? IF dup >r c@ or r> c! exit THEN drop ;   : immediate     $40 flag! ;                                     : restrict      $80 flag! ;                                     : macro  lastcfa @ ?dup  IF  2- dup  wx@ negate swap w!           here lastopt !  lastdes 2+ w@ w, relinfo here                   lastcfa @ >rel 0 lastcfa @ 2- wx@ negate dup 1- 3 >> 1+ allot   movebits  THEN ;                                              \ clearstack hallot heap heap?                    mod  05oct97py                                                                Code clearstack       user' s0 UP D) SP mov   AX pop                 Next end-code \ clearstack mu� Code bleiben                                                                                : hallot ( quan -- )  1- -cell and cell+ ( handler                BEGIN  @ dup  WHILE  over negate over cell+ +!  5 cells +       REPEAT  drop ) >r  s0 @  r@ -     sp@  dup r>                   - dup s0 !  2 pick  over -  move  clearstack    s0 ! ;        : heap    ( -- addr )        s0 @ $10 + ;                       : heap?   ( addr -- flag )   s0 @ up@ within ;                                                                                  | : heapmove   ( from -- from )                                     dup  here over -  dup hallot  heap swap move                    heap over - last +!  ;                                                                                                      \ DOES>  ;                                             01jan98py                                                                | : !does lastcfa @ 1+ call! ;                                  : (;code       r> 2+ !does ;                                    : DOES>  state @ IF    dup ?struc compile (;code !length  0 w,                   ELSE  0 w, here !does 0 ]  THEN                         here lastcfa ! compile r> ;   immediate                : dp! ( dp -- )  here over - >r                                   Relinfo over >rel r> 0 max erasebits dp ! ;                   : hmacro  macro  last @ ?dup                                      IF  heap? lastcfa @ and ?dup                                        IF  2- dup here over - dup hallot                                   heap swap move  dp!  heap 2+ dup lastcfa !                      heap dup wx@ abs 2+ + lastopt !                                 last @ (name> !  THEN  THEN ;                         \ For compile-time macros                                       \ ?head  | alignments  warning                         03jan03py                                                                Variable ?head     0 ?head !                                                                                                    : |                ?head @  ?exit  -1 ?head ! ;                                                                                 \ : halign           heap  3 and  hallot ;                                                                                      Variable warning   true warning !                               ' warning Alias warnings                                                                                                        : not  state @  IF    lastdes c@ :f =                                                 IF  compile 0=  ELSE  compile invert  THEN                ELSE  invert  THEN ;  immediate                                                                                                                                                 \ forward; exists?                                     12mar00py                                                                | : (forward  [call] c, here r@ @ , r> ! !lastdes ;                                                                             : forward ( -- ) | Header here $C hallot  heap last @ (name> !    heap dp ! compile (forward 0 ,  dp !                            reveal immediate restrict ;   immediate                                                                                       | : exists?     last @ current @ (find                              IF  name>  dup cfa@ ['] (forward =                                  IF   >body  dup @  swap off                                          BEGIN  dup  WHILE  dup @ swap >resolve  REPEAT                  drop  EXIT  THEN                                           warning @  IF  space last @ .name ." exists " ?cr  THEN     THEN  drop ;                                                | $400 Constant viewoffset      \ max. 1 MByte lange Files      \ makeview Create                                 mod  17jun10py: blk@ ( -- n )  blk @ dup 0= IF  line @ max  THEN ;            : makeview     ( -- %ffffffbbbbbbbbbb )  blk@ dup 0= ?exit        loadfile @  ?dup  IF  cell+  w@  viewoffset *   +  THEN  ;    Variable head+ 7 head+ !     Variable headalign 3 headalign !   : name?  name c@ dup 0= -&16 and throw dup $1F > -&19 and throw   head+ @ 0< IF  drop  EXIT  THEN                                 here + head+ @ swap - headalign @ and 0 ?DO  bl c,  LOOP ;    : Header  ( -- ) >in @  name?  >in !  here  makeview w,  -1 A,    name c@  here capitalize last !    1+ allot ( align )           ?head @  IF  1 ?head +!   dup 2+ A,         \ Pointer to Code                heapmove $20 flag!  dp!                            ELSE  drop  THEN  0 w, exists? here lastcfa ! :r lastdes ! ;  : Create  head+ push -5 head+ +!  Header  reveal ['] r> call,     DOES> ;  here $B - (create? 1- !                              : :   Header 0 ] ;                                              \ nfa?                                            mod  10mar93py                                                                Code nfa?   ( thread cfa -- nfa / false )  DX pop                    BEGIN  DX ) DX mov  DX DX test  0<> WHILE                              4 DX D) CL mov  $3F # CX and  5 # CX btr                        7 CX DX DI) CX lea                                              b IF  -2 CX D) CX mov  THEN  CX AX cmp                          0= UNTIL  4 DX D) AX lea  Next  THEN                     AX AX xor  Next  end-code                                  \ : nfa?   >r  BEGIN  @ dup 0= IF  rdrop exit  THEN             \                     dup cell+ name> r@ = UNTIL  cell+ rdrop ; : >name   ( cfa -- nfa / false )                                   context @  over nfa?  ?dup IF  nip exit  THEN  voc-link         BEGIN  @ dup  WHILE  2dup 8 - swap nfa?                                dup IF  >r 2drop r> exit  THEN  drop  REPEAT nip ;                                                                    \ : ; Constant Variable                                12mar00py: :noname  here 3+ -4 and dp !  makeview w,                       0 w, here dup lastcfa ! last off :r lastdes ! 0 ] ;           : !length   lastcfa @ 0= ?exit  lastcfa @ 2- w@ ?exit                       here lastcfa @ -    lastcfa @ 2- w!  ;              : ;         ?struc  compile unnest                                          !length  compile [ reveal ;  immediate restrict     : Alias ( cfa -- )  lastcfa push                                  Header reveal -2 allot last @ dup  c@ $20 and                   0= IF  0 A, $20 flag!  THEN  (name> ! ;                       : Variable          Create   0  , ;                             : 2Variable         Variable 0  , ;                             : AVariable         Create   0 A, ;                             : Constant    : swap compile Literal  compile ; hmacro ;        : AConstant   : swap compile ALiteral compile ; hmacro ;        : 2Constant   : -rot compile 2Literal compile ; hmacro ;        \ uallot User Alias                                    11mar00py: Value       Create ,  DOES>  @ ;  here $D - (value? 1- !      : AValue      dup Value  here cell- A! ;                        : uallot   ( quan -- offset )                                     udp @  under +   dup $7FFE u> abort" Userarea full"  udp ! ;  | : ualign   ( udp @ 1 and udp +! ) ;                           : User       ualign : compile (User cell uallot here 6 - !                            compile ; macro ;                         | : !Auser   ualign Mroot @ dup cell+ @ +  udp @                             [ udp tactModule @ - 8+ ] Literal + +Bit ;         : AUser      !Auser  User ;                                     : &  ( -- addr )  ' dup w@ [ ' (defer w@ ] Literal =              IF  2+ @ state @ IF compile (user  here 6 - ! ELSE up@ + THEN   ELSE  >body ?alit,  THEN  ;  immediate                        : to ( n -- ) compile & state @  IF  compile ! exit  THEN ! ;                                                  immediate        \ vp current context also toss                         31aug96py                                                                User vp         $20 cells uallot drop   \ Gives $20 Vocs        AUser current                                                                                                                   : context   ( -- addr )             vp @+ + ;                                                                                   | : thru.vocstack ( -- from to )    vp cell+ context ;          \ "Only Forth also Assembler" gives                             \ vp:  countword = 8 | Root | Forth | Assembler |                                                                               : also         vp @  $78 > IF  -&49 throw  THEN                                context @  cell vp +!  context ! ;               : toss         vp @  IF  -cell vp +!  THEN ;                    ' toss Alias previous                                           : definitions            context @ current ! ;                  \ Vocabulary Forth Only Onlyforth                      20may00pyPatch 'initvoc  ' drop IS 'initvoc                              Variable slowvoc  0 slowvoc !                                   AVariable voc-link                                              : voc, ( link -- ) dup IF @ THEN  dup A, A,                       here voc-link @ A,  dup voc-link ! slowvoc @ , 'initvoc ;     \ { Name | Code | Thread | Coldthread | Voc-link | Hash }       | : (Vocabulary   Header   ['] r> call,  voc,                       DOES>   context ! ;                                         : Vocabulary  0 (Vocabulary reveal ;                            Vocabulary Root                                                 | Defer Forth   ' Kernel IS Forth                               : Only          vp off  Root also definitions ;                 : Onlyforth     Only Forth also definitions ;                   : >rel ( addr -- reladdr )                                        thisModule @ - -1 max thisModule @ cell+ @ 1- min ;           \               *** Search order word set ***          12nov06py                                                                Create 'findpad    $21 allot                                    Patch 'prehash                                                  : WORDLIST        ( -- wid )  align here 0 voc, ;               : GET-ORDER       ( -- wid1 .. widn n )  vp dup @ cell/ dup >r    FOR  cell+ dup >r @ r>  NEXT  drop r> 1+ ;                    : SET-ORDER       ( wid1 .. widn n -- )                           -1 case? IF  Only exit  THEN  1- dup cells vp !  >r context r>  1+ 0 ?DO  dup >r ! r> cell-  LOOP  drop ;                     : GET-CURRENT     ( -- wid )  current @ ;                       : SET-CURRENT     ( wid -- )  current ! ;                       : FORTH-WORDLIST  ( -- wid ) also forth context @ toss ;        : SEARCH-WORDLIST ( addr u wid -- cfa state / f )                 >r 'findpad place 'findpad capitalize 'prehash  r> (find        IF found ELSE drop 0 THEN ;                                   \ body> order list> unlist words                    26apr98py ks                                                                : body>    ( pfa -- cfa )                                         5 - dup c@  [call] = ?exit  5 + ;                                                                                             | : .voc   ( addr -- )   @  body>  >name  .name ;               : order                  thru.vocstack DO  I .voc -cell  +LOOP                           2 spaces  current .voc ;               : list> ( thread -- element )                                     BEGIN  @ dup  WHILE  dup r@ execute                             REPEAT  drop rdrop ; restrict                                 : unlist  drop rdrop rdrop ; macro  restrict                    : words ( name drop ) context @  list>  ?cr cell+                 ( here 1+ c@ over 1+ c@ = here c@ 0= or                         IF ) .name space ( ELSE  drop  THEN )                           stop? IF  unlist  THEN ;                                      \ >name name> >body .name                              17jun10py                                                                : (name>   ( nfa -- cfa )      count  $1F and  + ( aligned ) ;  : name>   ( nfa -- cfa )                                           dup  (name> swap  c@ $20 and IF  @ exit  THEN  2+ ;                                                                          : >body   ( cfa -- pfa )                                            dup c@  [call]  = IF  5 +  exit  THEN                           dup c@  $BA     = IF  1+   exit  THEN   \ Patch                 dup w@  $95FF   = IF  2+ @ up@ + exit THEN  dup @ \ Defer   [ ' (suser @ ] Literal = IF  5 +  exit THEN  dup @              [ ' (user  @ ] Literal = IF  5 +  exit THEN  -&31 throw ;                                                                       : .name   ( nfa -- )                                               ?dup  IF  dup heap?  IF ." |" THEN                              count $1F and type  ELSE ." ???"  THEN space ;               \ found                                                16aug87we                                                                : found ( nfa -- cfa n )                                          dup c@ >r   (name> r@ $20 and  IF  @ 2-    THEN  2+                             -1 r@ $80 and  IF  1-      THEN                                    r> $40 and  IF  negate  THEN  ;            \\                                                              : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1<str2) over bounds DO   drop 1+ dup 1- c@ I c@ - dup                                  IF dup abs / LEAVE THEN LOOP nip ;              Variable string         Variable strlen                         : (find    ( string thread -- str false/NFA true )               >r count $1F and  strlen ! string !                             BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ =         IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN     THEN drop   REPEAT  string @ 1- false ;                     \ (find                                                27mar94py                                                                \ BX: thread  AX: string  DL: count   DH: first byte            Code list(find   ( string thread -- string false/ NFA true )         R: BX push  AX BX mov  lods  SI push  DI push                   AX ) DX movzx  $1F # DL and                                     BEGIN  BEGIN  BX ) BX mov  BX BX test                                         0= IF  DI pop  SI pop  BX pop                                          S: AX push  AX AX xor  Next :R  THEN                     4 BX D) CX movzx  $1F # CL and                                  CX DX cmp  0= UNTIL                                      2 AX D) SI lea  6 BX D) DI lea  0 # CH mov  CX dec              repe .b cmps  0= UNTIL   4 BX D) AX lea                  DI pop  SI pop  BX pop  S: AX push  -1 # AX mov                 Next end-code                                                                                                              \ find  ' [']                                          29aug99pyPatch ((find    ' list(find IS ((find                                                                                           : (prehash ( string -- string )  count $1F and 'findpad place     'findpad capitalize bl over count + c! ;                      ' (prehash IS 'prehash                                          : (find   ( string thread -- nfa t / string f )                   swap 'prehash swap ((find ;                                   : find    ( string -- cfa n / string false )                      dup 'prehash context                                            BEGIN  BEGIN  dup @ over  cell- @ =  WHILE  cell-  REPEAT              under @  ((find  IF  nip nip found  EXIT  THEN                  swap cell-  dup vp u> 0= UNTIL  2drop false ;                                                                          : '    ( -- cfa )     name find 0= IF no.extensions THEN ;      : [']                 ' compile ALiteral ;  immediate restrict  \ number conversion: digit?                            20feb95pyLabel fail      :S  AX AX xor  Next  T                          Code digit?    ( char -- n true : false )                            user' base UP D) DX mov  DX DX test                             0<> IF  A: upper AX D) AL mov                                           Ascii 0 # AL sub   fail < jmpIF                                 &10 # AL cmp                                                    >= IF  'A '0 -    # AL cmp  fail < jmpIF                               'A '9 - 1- # AL sub  THEN                                DL AL cmp  fail >= jmpIF  THEN                          ;c: true ;                                                 \\                                                              : digit?   ( char -- digit true/ false )                          '0 - dup 9 u> IF [ 'A '9 - 1- ] Literal -                       dup 9 u> WHILE ( unstrukturiert ) THEN                          base @  over u> ?dup  ?exit  THEN drop false ;                \ number conversion:  accumulate  convert              09aug07py                                                                Code accumulate   ( +d0 addr digit -- +d1 addr )                     AX CX mov  user' base UP D) AX mov  AX AX test                  0= IF  $100 # AX mov  THEN  AX push                             $8 SP D) mul  AX SP ) xchg  $C SP D) mul                        CX AX add  CX pop  CX DX adc                                    DX 4 SP D) mov  AX 8 SP D) mov  AX pop  Next end-code      : >number ( d addr count -- d addr count )                        0 ?DO  count digit?  WHILE  accumulate  LOOP 0                  ELSE  1- I' I - UNLOOP  THEN ;                                                                                                Patch char@  ' count IS char@                                   \\                                                              : accumulate ( +d0 addr digit - +d1 addr )                         swap >r swap  base @  um* drop rot  base @  um* d+ r> ;      \ dpl base? punctation?                                09aug07pyCreate bases  &10 c,  $10 c, %10 c, &10 c, 0 c, T               \             10      16     2      10     char                 : getbase  ( addr u -- addr' u' )  over c@ '# - dup 5 u<          IF  bases + c@ base ! 1 /string  ELSE  drop  THEN ;           : getsign  over c@ '- = dup >r negate /string r> ;              : s>number  ( addr len -- d )  base push                          getsign >r  getbase  base @ 0=                                  IF  over + swap char@ >r swap over - dup 0= >r 1 = >r               c@ '' = r> and r> or dpl !  r> 0 rdrop  EXIT  THEN          dpl on  getsign r> xor >r  0 0 2swap                            BEGIN  dup >r >number  dup r> =                                        IF  rdrop 2drop dpl off  EXIT  THEN                             dup  WHILE  dup dpl ! over c@ -3 and ', = 0=                    IF  rdrop 2drop dpl off  EXIT  THEN  1 /string           dup 0= UNTIL  THEN  2drop r> IF  dnegate  THEN ;              \ interpret                                            09aug07py                                                                : number? ( string -- string 0 / n -1 / d 0> )                    dup count s>number dpl @ 0= IF  2drop false  EXIT  THEN         rot drop dpl @ dup 0> 0= IF  nip  THEN ;                      : number ( string -- d )  count s>number dpl @ 0= abort" ?" ;                                                                   Defer parser                                                    Defer notfound                                                                                                                  : no.extensions  ( string -- )   error" don't know " ;                                                                          ' no.extensions Is notfound                                                                                                     : interpret                                                       BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;       \ interpreter compiler addrcompiler                    30apr92py                                                                | : interpreter  ( name -- ) find  dup                              IF  1 and  IF execute  exit THEN  -&14 throw  THEN  drop        number? 0= IF  notfound  THEN ;                                                                                             ' interpreter  Is  parser                                                                                                       | : compiler     ( name -- ) find  dup                              IF  0> IF  execute exit THEN cfa, exit THEN drop number? dup    IF  0> IF  swap compile Literal  THEN  compile Literal          ELSE  drop notfound  THEN ;                                                                                                 | : addrcompiler ( name -- ) find dup                               IF  0>  IF  execute  exit THEN A, exit THEN drop notfound ;                                                                 \ [ ] T] Table: cfa@                                   13nov94py                                                                : [     ['] interpreter  IS parser state off ; immediate        : ]     ['] compiler     IS parser state on  ;                  : T]    ['] addrcompiler IS parser ;                                                                                            : Table:    Create T] ;                                                                                                         : cfa@          ( addr -- addr' )  \ calc. address of subroutine  dup c@ [call] = IF  1+ @+ +  exit THEN ;                                                                                                                                                                                                                                                                                                                                                                                                                      \ in/output structure                                  22dec93py                                                                | : Out: (  Create dup c, cell+ ) Does> c@ output @ + perform ;                                                                 : Output:  Table:  Does> output ! ;                             0  Out: emit       Out: emit?      Out: cr         Out: type       Out: del        Out: page       Out: at         Out: at?        Out: form       Out: bot        Out: eot        Out: tflush     Out: curon      Out: curoff     Out: curleft    Out: currite    Out: clrline    drop                                         : at-xy ( x y -- ) swap at ;                                    | : In:  (  Create dup c, cell+ ) Does> c@ input  @ + perform ;                                                                 : Input:   Table:  Does> input  ! ;                             0  In: key         In: key?        In: decode      In: accept      In: eot?        drop                                         \ Defer Is                                             17apr94py                                                                \ : crash           true abort" crash" ;                                                                                        : Defer      ['] noop !AUser cell uallot                                     : compile (defer over , compile ; macro up@ + ! ;                                                                  : Patch      Header reveal compile (patch ['] noop here 6 - ! ;                                                                 : What's     compile & state @ IF compile @ exit THEN @ ;                                                    immediate          : Defers     ' >body @ cfa, ;                immediate restrict                                                                                                                                 ' TO alias IS immediate         \ No check is made!!                                                                            \ System constants, do_term                            20aug95py                                                                0 Value Mroot                                                   0 Value ftab                                                    0 Value FORTHstart              \ dummy!!!                                                                                      Variable sys-sp                                                                                                                 &386 Value CPU                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  \ ?stack                                               06apr96py| : dicfull  here s^ @ sp@ within ?EXIT                             reveal last?                                                    IF  dup heap?  IF  name>  ELSE  6 -  THEN  (forget  THEN        relinfo $BA - here umin dp !  -8 throw ;                    | : stackfull ( -- )  depth $20 > IF -3 throw THEN                  here sp@ > IF  clear true abort" Heap full!"  THEN ;                                                                        Code ?stack  R:                                                      user' s^ UP D) DX mov                                           RP DX sub   -$80 # DX cmp   ' stackfull >= jmpIF                user' s0 UP D) DX mov   4 # DX add    RP DX cmp                 >= IF   user' thisModule UP D) DX mov   cell DX D) DX add               user' dp UP D) DX sub   $BA # DX cmp                            ' dicfull < jmpIF   Next  THEN                          DX RP mov  AX pop  ;c: -4 throw ;                          \ Converting errors to text                            07aug10pyCreate syserr$  ," Error #    "                                 Create error$s  ' drop A, ' drop A, ' drop A, ' drop A,                         ' drop A, ' drop A, ' drop A, ' drop A,         \ ANSI,   signals, internal, X-errors,                          \ system, system,  system,   system                             : err$s  Create  DOES>  BEGIN  2dup c@ dup WHILE                         = IF  1+ "error !  drop  EXIT  THEN                      1+ count +  REPEAT   2drop ;                                  : >error ( n -- )  dup                                            dup lasterr ! dup -3 > IF  drop EXIT  THEN                      negate dup $FF and dup 0= IF  2drop  EXIT  THEN                 over $8 >> dup 7 u> IF  2drop drop  EXIT  THEN   base push hex  syserr$ "error ! lasterr @ negate 0 <<# # # # # #>              "error @ count + over - swap move #>>                           cells error$s + perform drop ;                                \ catch and throw                                      05oct97py                                                                Code end-trace  pushf  8 # SP ) btr  popf  Next end-code        Defer 'abort                                                    Defer 'catch                                                    : (catch ( addr rp -- )                                           rp@ handler ! >r execute  r> rp! r> handler ! 0 ;             ' (catch IS 'catch                                                                                                              Code catch ( i*w addr -- j*w 0 / i*w n )                             AX push  R: user' handler UP D) push  SP AX mov                 user' s0 UP D) CX mov  pusha                                    ' 'catch 2+ @ UP D) call  AX $1C SP D) mov  popa                user' handler UP D) pop                                         user' s0 UP D) CX sub  4 # SI add  CX neg  CX SI add            ;c: 'abort >error ;                                        \ catch and throw                                      05sep09py                                                                Create backtrace   $18 cells allot  0 ,                                                                                         Code throw ( n -- )  R: cld                                          AX AX test  0= IF  lods  Next  THEN                             backtrace $18 cells + A#) 0 # cmp                               0= IF  -1 # backtrace $18 cells + A#) mov                            backtrace A# DI mov  SI DX mov   SP SI mov  8 # CX mov          rep movs  $10 # CX add  DX SI mov  rep movs  DX SI mov     THEN  -1 # backtrace $18 cells + A#) mov                        user' handler UP D) DX mov  DX DX test                          0<> IF  DX SP mov  Next  THEN                                   ;c:  'abort >error  clearstack quit ;                                                                                                                                                      \ .status push load                                    21jun94py                                                                Defer .status   ' noop Is .status                                                                                               Variable loaderr                                                : saveerr ( -- )  loaderr @ 0=                                    IF  blk@ scr !  >in @ r# !  loadfile @ isfile !                     loaderr on  THEN ;                                                                                                        : (load   ( blk offset -- )    over 0= abort" No"                 ['] throw >r  loadfile push  blk push  >in push                 >in !  blk !  isfile@ loadfile !                                .status ['] interpret catch                                     dup IF  saveerr  ELSE  loadfile @ isfile !  THEN ;                                                                            : load   ( blk -- )   0 (load ;                                 \ +load thru +thru --> loadfrom include  rdepth depth  06apr96py                                                                : +load    ( offset -- )        blk @ + load ;                                                                                  : thru     ( from to -- )       1+ swap DO  I  load  LOOP ;     : +thru    ( off0 off1 -- )     1+ swap DO  I +load  LOOP ;                                                                     : -->                           1 blk +!  >in off  .status ;                                    immediate                                                                                       : loadfrom     ( n -- )                   \ load 1 scr from file               isfile push  fromfile push   use load  close ;   : include      1 loadfrom ;                                                                                                                                                                                                                                     \ quit (quit abort                                     29apr97pyDefer 'quit                                                     : prompt        state @ IF ."  compiled" exit THEN ."  ok" ;    : (quit         BEGIN .status cr query interpret prompt AGAIN ; ' (quit Is 'quit                                                : ?error "error @ dup IF errorhandler perform 0 THEN "error ! ; : quit   handler @                                                BEGIN  dup WHILE  dup r0 @ < WHILE  5 cells + @  REPEAT  THEN   handler !  r0 @ rp!                                             BEGIN  ?error compile [  ['] 'quit catch  dup  WHILE                   -$100 = 0= IF  clearstack  THEN  REPEAT drop ;         : (standardI/O  [ output ] ALiteral output cell 2* move ;       : (pushI/O      r> Output push  Input push  >r ;                Defer standardI/O       ' (standardI/O IS standardI/O           Patch pushI/O           ' (pushI/O     IS pushI/O               : abort         standardI/O  -1 throw ;                         \ (error abort" error"                            mod  17jun10py                                                                Variable lasterr                                                : (error ( string -- )                                            space count type space here .name  ?cr loaderr off ;          ' (error errorhandler !                                                                                                         : (abort"    "lit swap IF  "error ! -2 throw  THEN  drop ;      : (error"    "lit swap IF  "error !                                          handler @ ?dup IF  >r sp@ r> cell+ !  THEN                      -$100 throw THEN  drop ;                           : (abort       end-trace  >tib @ 0=  IF  $FF newtib  THEN ;     ' (abort Is 'abort                                                                                                              : abort"       compile (abort" ,"  ;   immediate restrict       : error"       compile (error" ,"  ;   immediate restrict       \ -trailing  space spaces                              26sep92py                                                                $20 Constant bl                                                                                                                 : -trailing ( addr1 n1 -- addr1 n2 ) bl -skip ;                                                                                 : space                      bl emit ;                          Label (spaces T here &80 dup allot bl fill                      : spaces   ( u -- )                                               0 max 0 ?DO  I' I - &80 min (spaces over type  +LOOP ;                                                                        Code  Qud/mod  ( d1 n -- d2 mod )  AX CX mov  AX pop                  DX DX xor  CX div  AX SP ) xchg  CX div  AX SP ) xchg           AX push  DX AX mov  Next end-code                                                                                                                                                         \ hold <# #> sign # #s                                 07aug10py| : hld   ( -- addr )             pad cell- ;                   | User hld-end                                                  : hold    ( char -- )           hld -1 over +! @ c! ;           : <#      ( -- )                hld dup dup ! hld-end ! ;       : #>      ( 64b -- addr +n )    2drop hld @ hld-end @ over -      hld-end @ hld = IF  hld-end off  THEN ;                       : <<#     ( -- )                hld-end @ 0= IF  <#               ELSE  hld-end @ hld @ - hold  hld @ hld-end !  THEN ;         : #>>     ( -- )                hld-end @ IF                      hld-end @ count bounds hld ! hld-end !  THEN ;                                                                                : sign    ( n -- )              0< IF  Ascii - hold  THEN ;     : #       ( +d1 -- +d2 )    base @ 2 max Qud/mod  9 over <        IF [ 'A '9 - 1- ] Literal +  THEN  '0 + hold ;                : #s      ( +d -- 0 0 )         BEGIN  # 2dup d0=  UNTIL ;      \ print numbers                                        07aug10py                                                                : d.r      >r under  dabs  <<# #s  rot sign #>                             r> over - spaces  type #>> ;                                                                                         : ud.r     >r <<# #s #> r> over - spaces type #>> ;                                                                             : .r       >r extend r> d.r ;                                   : u.r      0 swap ud.r ;                                                                                                        : d.       0 d.r space ;                                        : ud.      0 ud.r space ;                                                                                                       : .        extend d. ;                                          : u.       0 ud. ;                                                                                                              \ .s list c/l l/s                                      02nov01py                                                                variable maxdepth-.s            $10 maxdepth-.s !               \ : .s  depth maxdepth-.s @ min 0 max 0 ?DO i pick . LOOP ;     : .s ( -- )  ." <" depth 0 .r ." > "                                depth 0 max maxdepth-.s @ min                                   dup 0  ?DO  dup i - pick .  LOOP  drop ;                                                                                    $40 Value c/l           \ Screen line length                    $10 Value l/s           \ lines per screen                                                                                      : list ( blk -- )                                                 dup scr ! 3 spaces  file?  ." Scr " dup u.                      l/s 0 DO                                                          cr I 2 .r space scr @ block I c/l * + c/l -trailing type      LOOP cr drop ;                                                \ multitasker primitives                               21dec97pyCreate sleepers  sleepers A,  sleepers A,  0 ,  Variable 'UP    Code linkTask  ( task link -- )  DX pop   R: T                  Label (linkTask  ( ax:link dx:Task )  BX push                         cell DX D) CX mov  DX ) BX mov  BX CX ) mov                     CX cell BX D) mov  AX ) BX mov  BX DX ) mov                     AX cell DX D) mov  DX AX ) mov  DX cell BX D) mov               BX pop  lods  Next end-code                               Label >linkTask :R  SP user' TsaveRP UP D) mov  UP DX mov             sleepers A# AX mov  cell UP D) UP mov  (linkTask rel) call      AHEAD  T                                                  Label cont  SP user' TsaveRP UP D) mov  THEN                          0 UP D) UP mov  user' TsaveRP UP D) SP mov                      UP 'UP A#) mov  ret T                                     Code stop R: >linkTask A# CX mov user' Tsave UP D) jmp end-code Code pause R: cont A# CX mov  user' Tsave UP D) jmp  end-code   \ multitasker primitives                               30apr97py: wake    ( Taddr -- )    up@      linkTask ;                   : sleep   ( Taddr -- )    sleepers linktask ;                   AVariable semalink              Patch idle  ' 2drop IS idle     : Sema  AVariable  0 A,  here  semalink @ A, semalink ! ;       Code lock ( addr -- )  R:  AX ) DX mov                               DX DX and  0= IF  UP AX ) mov  lods  Next  THEN                 DX UP cmp  0= IF  lods  Next  THEN  cell # AX add               BEGIN  AX ) DX mov  DX DX and  0<> WHILE  DX AX mov                    user' lock> # AX add   REPEAT  UP AX ) mov               ( sti )  DX user' lock> UP D) mov  lods  ;c: stop ;        Code unlock   ( addr -- )  AX push  R:  ' lock rel) call             ( cli )  cell AX D) DX mov  DX AX ) mov  DX DX and              0= IF  ( sti )  lods  Next  THEN                                AX ) DX mov  user' lock> DX D) CX mov  CX cell AX D) mov        ( sti )  DX AX mov  ;c:  wake ;                            \ buffer mechanism / Module Memory                     17apr99pyAVariable prev       0 prev !     \ List-Head                   User  offset       0 offset !                                   Patch BlockR/W  ( File Pos Len Addr r=false/w=true -- )                                                                         Module Memory                                                                                                                   -1 Value HeapStart      -1 Value HeapEnd                        Variable Pool                                                   Label LastFree  Memory 0 ,                                      Label FirstFree Memory 0 ,                                      Label LastShift Memory 0 ,                                      Sema HeapSem                                                    Sema Shift?                                                                                                                     | : heapaligned ( size -- hsize ) $1B + -$10 and ;              \ Memory management macros                             29dec92py                                                                Code Full? ( Block -- Flag )                                         cell AX D) AX mov  Next end-code macro                     | ' Full? alias cell+@                                          Code PrevBlock ( Block -- PrevBlock )                                -cell AX D) AX sub  Next end-code macro                    Code NextBlock ( Block -- NextBlock )                                AX ) AX add  Next end-code macro                                                                                           | Code MakeEmpty ( start len -- )  DX pop                              AX -cell DX AX DI) mov  AX DX ) mov                             CX CX xor  CX cell DX D) mov  AX pop  Next end-code                                                                                                                                                                                                      \ Error handling                                       17apr99py                                                                Defer .memerr                                                   : ?memerr ( n -- ) $200 + negate throw ;                        ' ?memerr IS .memerr                                                                                                            | : (?addr ( addr -- flag ) dup HeapStart HeapEnd within            IF    dup 1 and 0=                                                    IF   8 - dup @ under + cell-                                         dup HeapStart HeapEnd within                                    0= IF  drop false  EXIT  THEN                                   @ = exit THEN                                        THEN  false nip ;                                           | : ?MP   ( MP -- MP )   dup @ (?addr 0= IF 3 .memerr THEN ;    | : ?addr ( addr -- addr ) dup (?addr 0= IF 2 .memerr THEN ;                                                                    \ (Split LastFree! <Split Split>                       10feb95py                                                                | : (Split ( block oldlen newlen -- block1 block2 )                 2dup = over 0= or IF 2drop dup exit THEN                        rot dup >r over MakeEmpty  dup r@ + dup >r -rot - MakeEmpty     r> r> swap ;                                                | : NextFree  ( first -- next )                                     BEGIN  dup Full?  WHILE  NextBlock  dup @ 0=  UNTIL  THEN ; | : LastFree! dup Full? 0= IF  LastFree !  ELSE  drop               HeapStart NextFree dup FirstFree ! LastFree !  THEN ;                                                                       | : <Split ( block oldlen newlen -- block1 block2 )                 (Split -1 2 pick cell+ ! dup LastFree!                          FirstFree @ NextFree FirstFree !  Pool @ NextFree Pool ! ;  | : Split> ( block oldlen newlen -- block1 block2 )                 over swap - (Split -1 over cell+ ! over LastFree! ;         \ WideUp Unite> Unite< GetMP                           28sep92py                                                                | : WideUp ( Block Var -- Block ) >r                                r@ @ over dup NextBlock within                                  IF dup r> ! ELSE rdrop THEN ;                                                                                               | : Unite> ( Block -- Block ) dup NextBlock Full?                   0= IF  dup dup @ 2dup + @ + MakeEmpty                                  Pool WideUp  FirstFree WideUp                                   LastShift WideUp  THEN ;                                                                                             | : Unite< ( Block -- Block ) PrevBlock dup Full?                   0= IF  Unite>  ELSE  NextBlock  THEN ;                                                                                      : GetMP ( Addr -- MP/false ) dup cell- @ 1+ dup  IF 1- dup        IF  abs 2dup @ = 0=  IF  cell+@  THEN  THEN  THEN  nip ;      \ Shift>all                                            17apr99py                                                                | : Shift> ( -- ) HeapSem lock LastShift @ dup dup NextBlock        over Full? 0> over Full? 0= and                                 IF    @ >r dup r@ + over 2dup 8+ GetMP >r over @ move                 8+ r> ! r> MakeEmpty                                      ELSE  2drop  THEN  unite< LastShift ! HeapSem unlock ;                                                                      : Shift>all ( -- )                                                Shift? lock  HeapEnd  PrevBlock                                 BEGIN  PrevBlock dup HeapStart = 0= WHILE                              LastShift !  Shift>  Pause  LastShift @  REPEAT          drop  Shift? unlock  ;                                                                                                                                                                                                                                        \ BlockR/W Backup                                      31dec92py                                                                | : MPLink    4 + ; macro  0 :#+ T&P                            | : Len       8 + ; macro  0 :#+ T&P                            | : Pos      $C + ; macro  0 :#+ T&P                            | : MPFile  $10 + ; macro  0 :#+ T&P                            | : Flag    $14 + ; macro  0 :#+ T&P                                                                                            | : Purge? ( MP -- flag ) dup @ cell- @ abs = 0= ;                                                                              : Purge@ ( MP -- File Pos Len / -1 ) ?MP dup Purge?               0= IF  drop -1 exit THEN  @ cell- @ abs >r                      r@ MPFile @  r@ Pos @  r> Len @ ;                             Label Masters    Memory 0 ,                                     Label PurgeInfos Memory 0 ,                                     Variable DiskDispose    0 DiskDispose !                         \ Variablen InitHeap NoHeap                            26feb94py                                                                : InitHeap ( addr -- )                                            dup [ ' HeapStart 5 + ] ALiteral !                              BEGIN  NextBlock dup @ 0= UNTIL  [ ' HeapEnd 5 + ] ALiteral !   Masters off  prev off  PurgeInfos off                           HeapStart LastFree!  LastFree @ dup Pool !  FirstFree !         HeapSem off Shift? off ;                                                                                                      cold:  Mroot cell+ @ InitHeap  ;                                                                                                                                                                                                                                                                                                                                                                                                                                \ DisposPtr HLock HUnLock GetPtrSize GetHandleSize     06feb00py                                                                : DisposPtr ( addr -- )  ?addr                                    HeapSem lock cell- dup off cell- Unite> Unite<                  FirstFree @ min  FirstFree ! HeapSem unlock ;                                                                                 : GetPtrSize ( Addr -- Len ) ?addr 8 - @ $C - ;                 : GetHandleSize ( MP -- Len ) ?MP @ GetPtrSize ;                                                                                : HLock   ( MP -- ) ?MP @ cell- dup @ abs negate  swap ! ;      : HUnLock ( MP -- ) ?MP @ cell- dup @ abs         swap ! ;                                                                      : HandleOff ( MP -- )                                             dup @ 0= IF  drop  EXIT  THEN  ?MP                              dup Purge?  IF  dup HNoPurge  THEN                              dup @ DisposPtr off ;                                         \ HNoPurge HUpdate Update DisposHandle emptybuf        24sep90py                                                                : BackupMP  ( MP -- ) ?MP  dup Purge?                             IF  dup @ cell- @ Flag wx@ 0<                                       IF  dup >r Purge@ r@ @ 1 BlockR/W                                   0 r> @ cell- @ Flag w! exit  THEN THEN  drop ;                                                                        : HUpdate ( MP -- ) ?MP @ cell- @ Flag $8000 swap w! ;                                                                          : emptyMP ( MP -- ) ?MP                                           dup Purge?  IF  dup BackupMP  THEN  DisposHandle ;                                                                                                                                                                                                                                                                                                                                            \ FreeMem MaxMem                                       26dec92py                                                                : FreeMem ( -- FreeLen ) Pool @ @ ;                                                                                             : MaxMem ( -- MaxLen )                                            Shift>all FirstFree @ Lastfree! LastFree @ @ >r  HeapStart      BEGIN  BEGIN  dup @  WHILE  dup Full?  WHILE                                  NextBlock  REPEAT                                        dup @ r@ >  IF  rdrop  dup @ >r  dup LastFree!  THEN            NextBlock  BUT AGAIN THEN drop r> $C - ;                                                                               \\                                                              : TotalFree ( -- TotalLen )  0 >r HeapStart                       BEGIN  dup Full?  0= IF  dup @ r> + >r  THEN                           dup 8+ GetMP ?dup IF Purge? IF dup @ r> + >r THEN THEN          NextBlock dup @ 0=  UNTIL  drop r> $18 - ;             \ PurgeLast ForcedMaxMem                               27sep92py                                                                | : PurgeLast ( -- Len ) 0 prev                                     BEGIN @ dup WHILE dup cell+@ @ cell- @  0> IF nip dup THEN      REPEAT  drop ?dup                                               IF cell+@ dup @ 8 - dup PrevBlock full? 0= IF PrevBlock THEN       >r emptyMP r@ LastFree! r> @  THEN ;                     | : ForcedMaxMem ( len -- len ) $C -                                BEGIN  dup Freemem <  IF  MaxMem >r  ELSE  0 >r  THEN                  dup r@ >  WHILE  r> LastFree @ >r >r                            BEGIN  prev @ 0= IF 1 .memerr THEN                                     r> PurgeLast + >r                                               dup LastFree @ @ $C - > 0=                                      IF  rdrop rdrop $C + exit  THEN                                 dup r@ > 0= UNTIL  rdrop r> LastFree!             REPEAT  rdrop $C + ;                                        \ Free>? Free<? FreeBlock                              06dec92py| : Free>? ( len -- len )                                           heapaligned >r  FirstFree @ dup LastFree!                       BEGIN  LastFree @ @ r@ <  WHILE                                        BEGIN  dup @ 0=                                                        IF  drop r> ForcedMaxMem                                            MaxMem drop exit  THEN                                      dup Full?  WHILE  NextBlock  REPEAT                      dup LastFree!  NextBlock  REPEAT  drop r> ;          | : Free<? ( len -- len )                                           heapaligned >r  Pool @ LastFree!  HeapEnd                       BEGIN  LastFree @ @ r@ <  WHILE                                        BEGIN  dup PrevBlock under =                                           IF  drop r> ForcedMaxMem exit  THEN                             dup Full?  0= UNTIL                                      dup LastFree!  PrevBlock  REPEAT  drop r> ;          \ Masters MoreMasters FindMaster GetMaster             28mar94py                                                                | : FreeBlock ( -- block len ) LastFree @ dup @ ;                                                                               : NewPtr ( len -- addr )                                          Free>? HeapSem lock FreeBlock                                   rot <Split drop 8+  HeapSem unlock ;                                                                                          : >Purge ( block file -- File Pos Len )                           under 0= IF  offset @ +  THEN  b/blk blk+ + dup >r * r> ;                                                                                                                                                                                                                                                                                                                                                                                                     \ DisposHandle NewHandle                               03jan99py                                                                : NewMP ( -- MP ) Masters cell $200 NewFix ;                                                                                    : SetHandle ( addr MP -- )  2dup ! swap cell- ! ;                                                                               : Handle! ( len MP -- ) >r                                        Free<? HeapSem lock  FreeBlock                                  rot Split> nip 8+ r> SetHandle HeapSem unlock ;                                                                               : DisposHandle ( MP -- ) dup HandleOff Masters DelFix ;                                                                         : NewHandle ( len -- MP ) NewMP under Handle! ;                                                                                                                                                                                                                 \ SetPtrSize SetHandleSize                             28feb95py                                                                : SetPtrSize ( Ptr Size -- ) heapaligned swap ?addr HeapSem lock  8 - under @ 2dup > 0=                                           IF  swap <Split  dup FirstFree @ min FirstFree !                    NextBlock unite< 2drop HeapSem unlock  exit  THEN           2 pick NextBlock dup Full? >r                                   @ + 2dup > r> or IF 4 .memerr THEN  2 pick unite>               drop swap <Split 2drop HeapSem unlock ;                                                                                       : SetHandleSize ( MP Size -- ) heapaligned over ?MP @ >r          dup r@ 8 - @ =  IF  rdrop  2drop  EXIT  THEN  $10 -             dup r@ 8 - @ <  IF  r@ swap SetPtrSize r> cell- ! EXIT  THEN    Free<? HeapSem lock FreeBlock rot Split> nip 8+                 2dup >r @ r> over GetPtrSize move                               2dup cell- ! swap ! r> DisposPtr ;                            \ MorePurgeInfos FindPurge HPurge                      21jun01py                                                                : DelFix ( addr root -- ) dup @ 2 pick ! ! ;                    : NewFix  ( root len # -- addr )                                  BEGIN  2 pick @ ?dup  0= WHILE  2dup * NewPtr                          over 0 ?DO  dup 4 pick DelFix 2 pick +  LOOP  drop       REPEAT  >r drop r@ @ rot ! r@ swap erase r> ;                                                                                 : HPurge ( File Pos Len MP -- ) ?MP >r                            PurgeInfos $16 $80 NewFix                                       >r  r@ Len !  r@ Pos !  r@ MPFile !  prev @ r@ !  r@ prev !     r> dup r@ @ cell- ! r> over MPLink ! 0 swap Flag w! ;                                                                         : HNoPurge ( MP -- ) ?MP >r r@ @ cell- @ abs >r                   prev dup @  BEGIN  r@ over = 0=  WHILE  nip dup @  REPEAT       drop r@ @ swap ! r> PurgeInfos DelFix  r> dup @ cell- ! ;     \ (core? FindMP                                        14mar93py                                                                | Code (core? ( F P L Addr -- F P L Addr/false )                       SI push  DI push                                                BEGIN  AX DX mov  AX ) CX mov  CX CX test  0<>  WHILE                  CX AX mov  8 AX D) SI lea  8 SP D) DI lea                       3 # CX mov  repe cmps  0= UNTIL                          AX ) CX mov  CX DX ) mov  prev A# DX mov                        DX ) CX mov  CX AX ) mov  AX DX ) mov                           ELSE  AX AX xor  THEN                                           DI pop  SI pop  Next end-code                            : FindMP ( File Pos Len -- MP )   prev (core?  dup                IF    >r drop 2drop r> MPLink @                                 ELSE  drop  dup  NewHandle >r dup 2over rot r@ HPurge                 r@ HLock  r@ DiskDispose !  r@ @ 0 BlockR/W                     DiskDispose off  r@ HUnLock  r>  THEN ;                 \ NoHeap PushHeap                                      27dec92py                                                                | : ThruHeap  HeapStart                                             BEGIN dup r@ execute  NextBlock dup @ 0= UNTIL drop rdrop ; | : HandlesOff ( -- )  ThruHeap 8+ getMP ?dup  IF  off  THEN ;  | : HandlesOn ( -- )                                                ThruHeap 8+ over full? abs dup 1 > IF ! ELSE 2drop THEN ;                                                                   : PushHeap ( -- )                                                 Shift? unlock  HeapSem unlock  HandlesOff                       r> execute  HandlesOn ;                                                                                                       Module; \ Memory                                                                                                                                                                                                                                                \ memory allocation word set                           28may00py                                                                Memory also                                                                                                                     : allocate  ( u -- addr ior )  ['] NewPtr catch ;               : free      ( addr -- ior )    ['] DisposPtr catch                dup IF nip THEN ;                                                                                                             | : (resize    ( addr1 u -- addr2 )                                 over GetPtrSize over <                                          IF    2dup ['] SetPtrSize catch 0= IF  drop exit  THEN                2drop NewPtr 2dup over GetPtrSize move swap DisposPtr     ELSE  over swap SetPtrSize  THEN ;                          : resize  over >r  ['] (resize catch                              dup IF  nip nip r@ swap  THEN  rdrop ;                                                                                        \ (diskerr                                        mod  28may00py                                                                : (diskerr ( error# throw# -- ) standardi/o                       DiskDispose @ ?dup  IF  DisposHandle DiskDispose off  THEN      >r ." error #"  dup lasterr !                                   base @ >r decimal negate . r> base ! r> throw ;                                                                               Defer diskerr                                                   ' (diskerr Is diskerr                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           \ Backup emptybuf core?                                01nov06py                                                                : Backup ( addr -- ) ?addr  GetMP  BackupMP ;                                                                                   : emptybuf ( addr -- )  dup 0= IF  drop  EXIT  THEN               MPLink @ dup HNoPurge  DisposHandle ;                                                                                         : Update ( -- ) prev @ ?dup  IF  MPLink @ HUpdate  THEN ;                                                                       : core? ( blk file -- dataaddr / false )                          >Purge  prev (core?                                             >r  2drop drop r> dup  IF  cell+@ @  THEN ;                                                                                                                                                                                                                                                                                   \ block & buffer manipulation                     mod  30dec92py                                                                : (buffer ( blk file -- addr )                                    >Purge  prev (core?  dup                                        IF    >r drop 2drop r> MPLink @                                 ELSE  drop dup NewHandle dup >r HPurge r> THEN @ blk+ + ;                                                                     : (block ( blk file -- addr )                                     >Purge  FindMP @ blk+ + ;                                                                                                     : isfile@   ( -- addr )       isfile @ ;  macro                                                                                 : buffer ( blk -- addr )      isfile@ (buffer ;                                                                                 : block  ( blk -- addr )      isfile@ (block ;                                                                                  \ Little File interface                                20feb00py                                                                Sema hostSem    \ host OS is not reentrant                                                                                      AVariable file-link     NIL file-link ! \ list thru fcb's       Module DOS                                                      Variable fcb-link                                               : filesize   @        ; macro   \ size in Bytes                 : filepos    @  cell+ ; macro   \ position in Bytes             : fileOSpos  @     8+ ; macro   \ OS position in Bytes          : filehandle @  $0C + ; macro   \ handle from OS                : filelink   @  $10 + ; macro   \ next valid file handle        : fileopen#  @  $14 + ; macro   \ Number of open                : fileno      cell+   ; macro   \ fileno. for VIEW              : filename   @  $16 + ; macro   \ name of file                  : handle  ( -- n )   isfile@ filehandle @ ;                     \ (capacity !fbc?                                      09aug98py                                                                Patch >path.file                                                ' noop IS >path.file                                                                                                            : openfile  ( C$ mode -- len handle/-error )                      >r >path.file r> fopen dup 0< ?EXIT >r 0 r@ 2 fseek r> ;                                                                      : (capacity  ( -- n )          \ calculates size in blocks        isfile@ dup r/w (open throw  filesize @ dup 0= ?exit            b/blk blk+ + u/mod swap IF  1+  THEN ;  \ add 1 block for rest                                                                : flushfile ( fcb -- ) >r prev @                                  BEGIN  dup  WHILE  dup MPFile @ r@ =                                   IF  dup @ >r cell+ @ emptyMP r>  ELSE  @  THEN           REPEAT  rdrop drop ;                                          \ close                                                29jul01py                                                                : ior ( n -- ior )  dup 0< IF  $400 -  ELSE  drop 0  THEN ;     : (close ( fcb -- ior )  dup 0= ?EXIT  dup @ 0= IF @ EXIT THEN    dup fileopen# dup w@ 1- tuck 0 max swap w!                      IF  drop  0  EXIT  THEN  dup flushfile                          dup filehandle @ dup 0>= IF  fclose  ELSE drop 0 THEN  ior >r   -1 over filehandle !  0 over fileopen# w!                       filesize off r> ;                                             : (open  ( fcb mode -- ior ) swap                                 dup 0= IF 2drop exit THEN   dup filehandle @ 0<                 IF  >r 0 r@ fileopen# w!  r@ filename swap openfile                 dup 0> IF    swap dup $7FFFFFFF umin r@ filesize !                           0 max r@ fileOSpos ! r@ filehandle ! 0                    ELSE  ior rdrop EXIT  THEN                           ELSE  >r drop 0  THEN  r> fileopen# dup w@ 1+ swap w!  ;      \ !file assign                                         21jun01py                                                                : unlink-file ( fcb -- )  >r  fcb-link                            BEGIN  dup @ dup  WHILE  dup r@ =  IF  r@ filelink @ rot !             ELSE nip THEN  filelink  REPEAT  rdrop 2drop ;         : assign  ( String count fcb -- )  >r                             r@ @ IF  r@ (close drop  r@ unlink-file  r@ HandleOff THEN      dup $1F + r@ Handle!  r@ @ over $1F + erase                     fcb-link @ r@ filelink ! r@ fcb-link ! -1 r@ filehandle !       r> filename swap move ;                                       : assign? ( file -- ) dup @                                       0= IF    dup >r cell- body> >name count $1F and r@ assign                r@ filename dup $100 0 scan drop over -                         bounds ?DO  I c@ tolower I c!  LOOP                             rdrop  ELSE  drop  THEN ;                                                                                            \ File primitives                                      25may03py0 constant r/o 1 constant w/o 2 constant r/w : bin ; immediate  : exe      [IFDEF] :unix    4 or ; macro 0. T&P [ELSE] ; [THEN] : w/+      [IFDEF] :unix $400 or ; macro 0. T&P [ELSE] ; [THEN] : nonblock [IFDEF] :unix $800 or ; macro 0. T&P [ELSE] ; [THEN] : !fid  ( addr count -- fid )  NewMP dup >r assign r> ;         : !files  dup isfile ! fromfile ! ;                             : unlink? ( fid ior -- fid ior )  dup                             IF  over unlink-file swap DisposHandle 0 swap  THEN ;         : source-id ( -- 0 / -1 / fid )  >tib @ @ @ dup                   IF drop blk @ IF loadfile @ ELSE -1 THEN THEN ;               : ?pos ( fd -- ior )  dup filepos 2@ tuck = IF 2drop 0 EXIT THEN  swap 2dup fileOSpos ! filehandle @ 0 fseek ior ;              : iorpos ( r fd -- -error/bytes )  over 0> IF                        2dup filepos +!  2dup fileOSpos +! dup fileOSpos @              over filesize @ max over filesize ! THEN  drop ;           \ File operations                                      29jul01py                                                                : open-file ( addr count x1 -- fid ior )                          -rot !fid  dup >r swap (open                                    dup 0= IF  drop 0 r@ filehandle @ 0 fseek                                  0>= IF  0 r@ fileOSpos !  THEN  0  THEN              r> swap unlink? ;                                             : create-file ( addr count x1 -- fid ior )                        >r !fid  r> swap >r                                             r@ filename swap fcreate dup 0>=                                IF  dup r@ filehandle !  0 swap 2 fseek  1 r@ fileopen# w!          dup 0>=  IF  dup r@ filesize ! r@ fileOSpos ! 0 THEN THEN   r> swap ior  unlink? ;                                                                                                        : close-file  ( fid -- ior )  dup >r (close                       r@ fileopen# w@ ?EXIT  r@ unlink-file r> DisposHandle ;       \ File operations                                      02sep00py: read-file ( c-addr u1 fileid -- u2 ior )  dup ?pos              dup 0< IF  nip nip nip 0 swap  EXIT  THEN  drop dup >r          filehandle @ fread dup r> iorpos ior swap 0 max swap ;        : write-file ( c-addr u1 fileid -- ior )    dup ?pos              dup 0< IF  nip nip nip  EXIT  THEN  drop >r                     r@ filehandle @ fwrite r> iorpos ior ;                        \         /string  dup  WHILE  pause  REPEAT  0  THEN           \  nip nip ior rdrop ;                                          : file-position  ( fileid -- ud ior ) filepos @ 0 0 ;           : reposition-file ( ud fileid -- ior ) nip filepos ! 0 ;        : file-size ( fileid -- ud ior ) filesize @ 0 0 ;                                                                               [IFDEF] :GO32   cold:  0 $20003301 ms-dos drop ;  [ELSE]                        cold:  @libs ;                    [THEN]        Module; ( DOS )  DOS also                                       \ block & buffer manipulation                     mod  24may97py                                                                Patch capacity ( -- n )                                         ' (capacity IS capacity                                                                                                         : save-buffers  prev  LIST>                                       dup Flag wx@ 0<  IF dup cell+@ backupMP  THEN drop ;                                                                          \ : close-files   file-link  LIST>  cell+ (close drop ;         : close-files                                                     fcb-link  LIST> (close drop  dup @ IF filelink THEN ;                                                                         : empty-buffers prev  LIST>  cell+@  DisposHandle drop prev ;                                                                   : flush         save-buffers empty-buffers close-files ;                                                                        \ open close close!  File, File                        30aug03py                                                                : open   isfile@ r/w (open                                        dup IF  drop isfile@ r/o (open  THEN  throw ;                 : close  isfile@ (close throw ;                                 : close! isfile@ filehandle @ 0>= negate                          isfile@ fileopen# w! close ;        \ Schlie�t auf alle F�lle                                                                 | Variable #file ( -- n )       1 #file !                       : File,  here file-link @ A,  file-link !                         0 , #file @ 1+ dup #file ! w, ;                               : File ( -- )  Create   File,                                     DOES> [ here &10 - swap ] cell+ dup !files assign? ;                                                                                                                                                                                                          \ direct .file file? use                               02dec06py: direct 0 !files ;                                             : >len ( addr -- addr len ) dup $400 0 scan drop over - ;       : .file ( fcb -- ) ?dup 0= IF  ." DIRECT ! " exit  THEN            filename >len type space ;                                   : file?  isfile@ .file ;                                        | : isfile?     ( addr -- addr f ) \ is addr a fcb ?                dup cfa@ [ swap ] ALiteral = ;                              : /parse ( -- addr u )  >in @ char swap >in ! dup '" = over '' =  or IF  dup parse 2drop parse  ELSE  drop parse-name  THEN  ;  : /name ( -- addr )  /parse 2dup '/ -scan nip /string             here place here ;                                             : use ( -- )  >in @  /name  find                                  IF  isfile?  IF  execute open drop exit  THEN  THEN             drop  dup >in ! /name c@ invert >in +!  File  >in ! /parse      lastcfa @ >body cell+ dup !files  assign open ;               \ endpoints of forget                                  21apr93py                                                                | : endpoints ( addr -- addr symb )                                 heap  voc-link @  list> \ through all Vocabs                    >r 8 - >r    \ link on returnstack                              BEGIN  over r> @ dup >r  u> 0=  \ until link under addr         WHILE  r@ heap? YET  UNTIL      \ search for a name in heap            r@ cell+ c@ $20 and                                             IF  over r@ cell+ name> under u> 0= swap heap? or                   IF  r@ cell+ (name> cell+ umax  THEN                        THEN  REPEAT  rdrop r>  ;   \  then update symb                                                                                                                                                                                                                                                                                                                                     \ Module vergessen                                     26feb95py                                                                | : !dp  thisModule @ dup @ + dp ! ;                            : rm-module ( module -- ) dup >r cell- -1 over +!                 @ 0>  IF  rdrop exit  THEN  savedp                              r@ thisModule @ >r dup thisModule ! !dp heap forget-words       r> thisModule ! !dp                                             r@ 8+ @  IF  rdrop exit  THEN  r@ $C + @ 8+ dup @               BEGIN  dup r@ = 0=  WHILE  nip $10 + dup @  REPEAT              $10 + @ swap !  r> dup ModuleBye  cell- DisposPtr ;                                                                           | : <Module> ( addr symb -- addr symb )                             exportlink LIST>  >r dup heap?                                  IF 2dup <  IF  $C + umax  ELSE  drop  THEN  ELSE  >r over          r@ cell+ @ < IF swap r@ umin swap THEN rdrop THEN r> ;                                                                   \ remove, -words, -tasks                               19feb92py                                                                | : remove? ( dic symb addr -- dic symb addr flag ) dup heap?       IF  2dup u>  ELSE  dup 3 pick relinfo within  THEN ;                                                                        : remove ( dic sym thread - dic sym )                             BEGIN  dup @ dup  WHILE  swap >r remove?  \ unlink forg. words         IF  @ r@ ! r> ( unlink word)  ELSE  rdrop  THEN          REPEAT 2drop ;                                                                                                                | : remove-words ( dic sym -- dic sym )                             voc-link  list>  >r cell- cell- remove r> ;                                                                                                                                                                                                                                                                                 \ remove-files remove-memory remove-memory             20may00py                                                                | : remove-files ( dic symb -- dic symb )  \ flush files!           isfile@    remove?  IF  forth.fb     THEN  drop                 fromfile @ remove?  IF  fromfile off  THEN  drop file-link      BEGIN  @ dup WHILE remove?                                             IF  dup cell+ dup (close drop unlink-file  THEN          REPEAT  drop file-link remove ;                             | : remove-memory ( dic symb -- dic symb ) HeapStart 0< ?exit       ThruHeap >r full? 1- -2 u< IF  r@ 8+ GetMP                               remove?  IF  HandleOff  ELSE  drop  THEN THEN r> ; | : remove-module ( dic sym -- dic sym )  exportlink                BEGIN  @ dup  WHILE  remove?                                           IF  dup 8+ @ rm-module  THEN  REPEAT  drop               exportlink remove ;                                                                                                         \ remove-vocs forget-words                        mod  26feb95py                                                                | : 'Forth ( -- addr )   ['] Forth >body @ >body ;              | : remove-vocs ( dic symb -- dic symb )                            voc-link remove       thru.vocstack                              DO  I @ remove? IF  'Forth I ! THEN  drop -cell +LOOP          current @ remove?                                               IF  'Forth current !  THEN drop ;                                                                                           Patch custom-remove   ' noop Is custom-remove                                                                                   | : forget-words ( dic symb -- )                                    custom-remove  remove-vocs                                      remove-words   remove-files                                     remove-memory  remove-module                                    heap swap - hallot dp!  0 last ! ;                          \ deleting words from dict.                            21may93py: clear         here  dup up@  forget-words  dp! ;              : (forget ( addr -- )   dup heap? abort" is symbol"                                     endpoints <Module> forget-words ;       : forget  name find  0= IF  ." can't forget " .name exit  THEN            >name dup heap?  IF  name>  ELSE  6 -  THEN                     dup thisModule @ dup dup cell+@ + within invert                 over [ dp ] ALiteral @ < or  IF  -&15 throw  THEN               (forget ;                                             : marker  here heap udp @  Create , A, A,                                 DOES>  dup @ udp ! cell+ 2@ forget-words ;            : empty   [ dp ]  ALiteral @  up@ forget-words                            udp cell+@  udp ! ;                                   : save    clear  udp @ udp cell+ !                                up@ 8+ udp $10 + udp @ maxudp min 8 - move                      voc-link  LIST>  cell- dup >r cell- @ r> ! ;                  \ save bye stop? ?cr                                   27mar93py: ModuleBye  ( root -- )  r> swap dup                             BEGIN  BEGIN  dup 8+ @  dup  WHILE  nip  REPEAT  drop                  BEGIN  dup $20 + perform 2dup = IF 2drop >r exit THEN                  $10 + dup @  0= WHILE  cell- @ REPEAT @ AGAIN ; : bye    eot lasterr off Mroot @ ModuleBye 0 (bye ;             : badbye Mroot @ ModuleBye lasterr @ (bye ;                     | : end?    key $FF and dup 3 =   \ Stop                                          swap $1B = or   \ Escape                          IF true rdrop THEN ;                                        : stop? ( -- flag )     key? IF  end? end?  THEN false ;        : row  ( -- row )  at? drop ;                                   : col  ( -- col )  at? nip ;                                    : rows ( -- row )  form drop ;                                  : cols ( -- col )  form nip ;                                   : ?cr                col  cols $10 -  u> IF  cr  THEN ;         \ Alias  only definitionen                             20may00py                                                                Root definitions                                                                                                                : seal  context @ vp off context ! ;  \ kill all words in Root                                                                  ' Only        Alias Only                                        ' Forth       Alias Forth                                       ' words       Alias words                                       ' also        Alias also                                        ' definitions Alias definitions                                                                                                 Kernel definitions                                                                                                                                                                                                                                              \ input strings                                        06apr96py                                                                \ tib: { back | len | maxlen | prev | next | char[maxlen] }     \ if maxlen=0, char[maxlen] points to real tib                  : max#tib ( -- addr )   >tib @ @ 8+ ;                           : tib ( -- addr )       >tib @ @ $14 + max#tib @ 0= IF @ THEN ; : #tib ( -- addr )      >tib @ @ cell+ ;                        : newtib ( len -- )     >r r@ $14 + NewHandle  >tib @ over @ !    dup dup dup @ $C + 2! >tib ! r> max#tib !  #tib off ;         : moretibs ( n -- ) >r >tib @ r>                                  0 ?DO  max#tib @ newtib >tib @ @ >r  r@ @ @                            dup $10 + @ r@ @ r@ $C + 2!  dup @ r@ !                         >tib @ swap $10 + ! >tib @  r> $10 + @ @ $C + !  LOOP    >tib ! ;                                                      : deltib ( -- )         >tib @ dup @ @ >tib !   dup               BEGIN  dup >r @ $10 + @ r> DisposHandle  2dup = UNTIL  2drop ;\ input strings                                        26dec07py                                                                : ">tib ( addr len -- ) r> -rot  line push blk push >in push      blk@ invert line ! blk off  >in off  dup newtib                 >r tib r@ move r> #tib ! execute deltib ;                     : execute-parsing ( addr len xt -- )  -rot ['] throw >r           over 4  ">tib  #tib ! tib ! max#tib off                         catch dup IF saveerr THEN ;                                   : evaluate ( addr len -- )  ['] interpret execute-parsing ;     | : settib ( offset -- ) >tib @ @ + @ >tib ! ;                  : nexttib $10 settib ;                                          : prevtib $0C settib ;                                                                                                          : query  ( -- )   #tib @ IF  nexttib  THEN  line on               >tib @ HLock    tib max#tib @ accept space #tib !               >tib @ HUnLock  >in off  blk off ;                            \ Modul-Struktur                                       06jun08py\ Modulstruktur: { len | maxlen | head | back | next | cs |     \                  >cold | >main | >bye | >init | [RET] }                                                                       $80000    Value    MaxModLen                                    &10 cells Constant ModHeader                                                                                                    | : ModInit  dup >r dp ! 0 , MaxModLen , 0 , thisModule @ dup ,     8+ dup @ , r@ swap ! 0 , r@ thisModule !                        r> $28 + dup dup dup A, A, A, A, [RET] w, ;                                                                                 : FindMod ( string root -- module / 0 )                           BEGIN  2dup [ ModHeader 8+ ] Literal + dup c@ 1+ swap -text            0= IF  nip exit  THEN  2dup 8+ @ ?dup                           IF  FindMod dup  IF  nip nip exit  THEN  THEN  drop             $10 + @  dup 0= UNTIL  nip ;                           \ Modul-Struktur                                       20may00py: savedp  thisModule @ >r here r@ - r> !                          thisModule @ 5 cells + @ ?EXIT                                  0 here thisModule @ ?DO  I @ + dup 2* swap 0< - cell +LOOP      thisModule @ 5 cells + ! ;                                    | User linkit                                                   : joined  context @ linkit ! ;                                  : Module[ savedp                                                  name capitalize Mroot @ FindMod dup 0= abort" No Module!"       dup thisModule ! dup dup @ + dp !                               $30 + name> execute also definitions ;                        : Module  ( -- ) ( <Name> )  ?head push ?head off  savedp         MaxModLen dup 3 >> + cell+  dup NewPtr under                    swap erase 1 over ! cell+  ModInit                              headalign push headalign off  linkit @ (Vocabulary  linkit off  lastcfa perform  also definitions  reveal ;                   \ Exporting words from an Module                       17jun10py                                                                | : "Alias ( nfa -- )  here swap dup 6 - w@ w,  -1 A,               here last ! dup c@ $1F and 1+ ( aligned) >r dup here r@ move    r> allot  name> A, $20 flag!                                    ?head @  IF  heapmove  dp!  ELSE drop THEN  reveal ;                                                                        | : vec! ( dp n -- ) cells $18 + thisModule @ + ! ;             | : vec: ( n -- ) Create c, DOES> >r :noname swap r> c@ vec! ;                                                                  0 vec: cold:    1 vec: main:    2 vec: bye:   | 3 vec: (export:                                                                 \ syntax: export {word };                                                                                                                                                                                                                                       \ Exporting words from an Module                       24feb95py| : (export!  ?head @                                               IF $C hallot heap 2dup 8+ ! ELSE here 0 A, 0 A, over A, THEN    exportlink @ over ! exportlink ! r> execute                     ?head @ IF  heap 1 ?head +!  ELSE  here  THEN                   exportlink @ cell+ ! ;                                                                                                      : export:  (export:  compile (export! ;                         : exportVoc  ( Module -- ) [ ModHeader 8+ ] Literal + "Alias ;  | : (export r@ cell+ r> @ bounds ?DO  i @ "Alias  cell +LOOP ;  | : 'export dup w@ $3B01 ( [ " ;" w@ ] Literal ) =                  IF  drop >resolve compile ; exit  THEN                          current @ (find 0= IF -&13 throw THEN  A, ;                 : export  ( -- )  state @ 0= IF  export:  compile drop THEN       compile (export here 0 ,                                        ['] 'export IS parser ;  immediate                            \ Modul-Struktur                                       17jun10py                                                                : Module]  savedp thisModule @ $C + @ dup thisModule !            dup dup @ + dp ! toss [ ModHeader 8+ ] Literal + name> execute  definitions ;                                                                                                                 : Module;  ( -- )  ( align )                                      thisModule @ ModHeader + dup cell- @                            = IF  export:  compile exportVoc  compile ;  THEN               savedp  thisModule @  >r                                        r@ dup cell+@ +  r@ @ $120 + r@ cell+ !                         r@ dup cell+@ dup >r + r> 1- 3 >> 1+ dup >r move                r> r@ cell- dup 8+ @ rot + cell+ SetPtrSize                     Module]  r> dup [ ModHeader cell- ] Literal + perform ;                                                                                                                                       \ ModuleCold ModuleMain                                12mar00py                                                                : ModuleCold  ( root -- )                                         BEGIN  dup 8+ @  dup                                                   IF  ['] ModuleCold >r swap   ELSE  drop  THEN                   dup $18 + @ >r  $10 + @  dup  0= UNTIL  drop ;         | : ModuleMain  ( root -- )                                         BEGIN  dup >r 8+ @  dup  IF  ModuleMain  ELSE  drop  THEN              r@ $1C + perform r> $10 + @  dup                         0= UNTIL  drop ;                                                                                                            | : init-vocabularys        voc-link                                LIST>  dup cell- @  over cell- cell- ! 'initvoc ;           \\  ModuleCold starts relatet (by putting to RS)                    ModuleMain starts immediate (by execute)                    --> ModuleBye starts immediate and non-recursive (pushes!)      \ argc arg interpret-args                              03jul07py                                                                : argc  Mroot $18 + ;                                           : arg   cells Mroot $1C + @ + @ >len ;                          0 Value script?                                                 | : tib-include ">tib include 2 ;                               Vocabulary -options             -options definitions            Patch -i        ' tib-include IS -i                             : -e  evaluate 2 ; ( addr u -- n )                              ' -e Alias --evaluate ( addr u -- n )                           : -h  ( addr u -- n )  2drop 1  ." Image Options:" cr             ."   FILE                              load FILE" cr            ."   -e STRING, --evaluate STRING      interpret STRING" cr     bye ;                                                         ' -h Alias --help                                               Kernel definitions  -options also                               \ interpret-args                                       03jul07pyVariable arg#                                                   : do-arg ( addr u addr u -- n )                                   2dup [ ' -options 5 + ] Aliteral search-wordlist                IF  nip nip execute  ELSE  2swap 2drop -i 1-  THEN ;          : interpret-args ( -- )  argc @ 1 ?DO  I arg# !                       I 1+ I' = IF  s" "  ELSE  I 1+ arg  THEN                        I arg  do-arg  +LOOP ;                                    | : cold-catch ( xt -- ) catch ?dup                                 IF  ?error cr badbye THEN ;                                 | : do-command [ ' script? 5 + ] ALiteral on                        warning dup push off                                            ['] .status >body @ >r  ['] noop IS .status                     ['] interpret-args cold-catch                                   r> IS .status [ ' script? 5 + ] ALiteral off ;              toss                                                            \ 'cold 'restart                                       14jul03py\ Mroot 4+ @ 8+                                                 $20 Value #tibs                                                 | : (cold    udp $10 + up@ 8+ maxudp 8 - move  0 0 hostSem 2!       lasterr off  handler off  fcb-link off                          backtrace $18 cells + off                                       r0 @ mroot $14 + @ - s^ !  thisModule @ IF  !dp  THEN           Mroot @ 8+ @ ['] ModuleCold cold-catch   init-vocabularys       Only Kernel definitions  compile [  thisModule @ 0=             IF  Mroot @ dup thisModule ! dup @ + dp !                           joined S" Module FORTH" evaluate  lastcfa @ IS Forth        THEN  here [ dp ] ALiteral !                                    >tib @ 0=  IF  $FF newtib #tibs 1- moretibs  THEN               Onlyforth Mroot @ ModuleMain ;                              Patch 'restart  ' noop IS 'restart                              | : (restart  ['] (quit IS 'quit  'restart  handler off  abort ;\ trap with external debugger                          06apr96py                                                                Variable dumped  8 cells allot  4 cells allot                   Create except#   -$A ,   -9 ,   -9 ,   -9 ,                                      -$B ,  -$B , -$14 ,   -9 ,                                       -9 , -$1C ,   -9 ,   -9 ,                                       -9 ,   -9 ,   -9 ,   -9 ,                                     -$2A , -&23 , -$2B , -$2C ,                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     \ trap with external debugger                          18feb98pyLabel recovered  pusha  gs: $6E #) AX movzx  4 # AX shl               gs: $6C #) BX movzx  BX AX add                                  gs: $A AX D) AX movzx  4 # AX shl                               .w gs: 0 # $220 AX D) mov                                       dumped A# DI mov  SP SI mov  \ SS push  DS pop                  $B # CX mov  SS: rep movs  popa  3 cells # SP add               ES AX mov  AX SS mov   \ AX DS mov                              SP RP cmp  u> IF  :S R:  THEN   'UP A#) UP mov                  user' s0 UP D) SI cmp  u>  IF  user' s0 UP D) SI mov  THEN      user' s^ UP D) SI cmp  u<= IF  user' s0 UP D) SI mov  THEN      dumped $B cells + A#) AX mov                                    $13 # AX cmp  u>  IF  $13 # AX mov  THEN                        A: except# AX *4 I#) AX mov  A:: ' throw rel) jmp               end-code                                                  Create except'  $14 0 [DO]  recovered A,  [LOOP]                \ buserror addrerror illeg div0                        25aug96pyCode CS@  AX push  CS AX mov  Next end-code  macro  :ax 0 T&P   Code DS@  AX push  DS AX mov  Next end-code  macro  :ax 0 T&P                                                                   \\ : DPMIidt! ( handler n -- )  tuck  4* 2* DPMIexps + 2+ !          dup 4* 2* DPMIexps + CS@ rot $70000203 $31 int drop ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      \ cold:                                                14jan01py                                                                : rspace  mroot 9 cells + @ ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   \ cold bootsystem                                      20aug95py                                                                Code cold  THEN   SI push  $18 # DI mov  s0 A#) DI add               udp $10 + A# SI mov   maxudp 4/ 2- # CX mov                     rep movs  ' (cold A# DX mov                                [IFDEF] :GO32                                                        DS AX mov  GS BX mov  AX BX cmp                                 0= IF  $10 # AX sub  AX GS mov  THEN                       [THEN]                                                          \    int3  \ Breakpoint for testing                             Label bootsystem  $10 # UP mov   s0 A#) UP add  UP 'UP A#) mov       user' s0 UP D) SP mov  user' r0 UP D) RP mov  0 # RP ) mov      R: DX push   0 # user' handler UP D) mov  lods ;c:              !recover ;                                                                                                                                                                                 \ System dependent load screen                         18jun09pyCode restart  R: ' (restart A# DX mov                                bootsystem rel) jmp end-code                               File forth.fb                                                   [IFDEF] :win32  : win32 ; [THEN]                                [IFDEF] :go32   : go32 ;  [THEN]                                [IFDEF] :os/2   : os/2 ;  [THEN]                                [IFDEF] :unix   : unix ;  [THEN]                                [IFDEF] :linux  : linux ; [THEN]                                [IFDEF] :osx    : osx ;   [THEN]                                [IFDEF] :glibc  : glibc ; [THEN]                                [IFDEF] :bsd    : bsd ;   [THEN]      : bigforth ;              main: [IFDEF] :unix  !signals  [THEN]                                 forth.fb do-command standardi/o bot                             cr  FORTHstart 2+ count  cols over - 2/ spaces  type cr         ( restart ) quit ;                Module; \ KERNEL        \ System patchup                                  mod  11jul96py                                                                H                                                               Tudp @          T dup udp !  udp cell+ ! H                      [IFUNDEF] :GO32                                                 Tlibs @         T also dos libs ! toss H                        [THEN]                                                          Tvoc-link @     T voc-link ! H                                  Tfile-link @    T file-link ! H                                 Tsemalink @     T semalink ! H                                  Host  move-threads                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              \ (ins (del                                            28dec04py                                                                | : (del   ( m s addr pos1 -- m s addr pos2 ) 2 pick 0= ?exit       at? >r >r  2dup 4 pick swap /string 1- 2dup                                over 1+ -rot move type space rot 1- -rot             r> r> at ;                                                  : cur+       >r at? r> + cols /mod swap >r + r> at ;            : >string  ( span addr pos1 -- span addr pos1 addr2 len )           over 3 pick 2 pick chars /string ;                          : <ins>   ( m s addr pos1 char -- m s addr pos2 ) >r              >string  2dup over 1+ swap move 1+                              r> 2 pick c!  tuck type 1- negate cur+ rot 1+ -rot 1+ ;       | : prevline   ( m s addr pos1 flag -- m s addr pos2 )              >r 2drop   clrline  dup IF #tib ! ELSE drop THEN                >tib @ HUnlock r> IF nexttib ELSE prevtib THEN                  >tib @ HLock  tib over #tib @ min 2dup type  under ;        \ decode                                               14apr10py: <prev>  over tib =   IF  0 prevline THEN                0 ;   : <next>  over tib =   IF -1 prevline THEN                0 ;   : <forw>  dup 3 pick < IF currite 1+  THEN                0 ;   : <back>  dup          IF curleft 1-  THEN                0 ;   : <del>   dup 3 pick < IF (del        THEN                                dup 3 pick d0= IF  bye      THEN                0 ;   : <bs>    dup IF curleft 1- (del THEN                     0 ;   : <beg>   negate cur+ 0                                   0 ;   : <end>   >r over dup r> - cur+                           0 ;   : <clr>   negate cur+ over spaces swap negate cur+ 0 tuck 0 ;   Create ctrlkeys                                                  T] false  <beg>  <back> false   <del>  <end>  <forw> false         <bs>   false  true   <clr>   false  true   <next> false         <prev> false  false  false   false  false  false  false         false  false  false  false   false  false  false  false [   \ decode                                               28dec04py                                                                Variable lastkey                                                                                                                Create scancode $100 allot                                         ctrl B char K scancode + c!  ctrl F char M scancode + c!        ctrl P char H scancode + c!  ctrl N char P scancode + c!        ctrl A char G scancode + c!  ctrl E char O scancode + c!        ctrl D char S scancode + c!  ctrl O char R scancode + c!                                                                     : ctype? ( key -- char type )  dup lastkey !                      [IFDEF] :unix  dup $7F =  IF  drop $08  THEN  [THEN]          \  dup $FF and dup $E0 = swap $00 = or                          \  IF  8 >> scancode + c@ false  EXIT  THEN  $FF and              dup bl >= ;                                                   Patch everychar ' noop IS everychar                             \ accept keyboard                                      05apr96py                                                                : PCdecode ( max span addr pos1 key -- max span addr pos2 flag )  everychar  ctype?                                               IF    >r 2over = IF  rdrop bell 0 exit  THEN  r> <ins> false    ELSE  cells ctrlkeys + perform  THEN ;                                                                                        : PCaccept   ( addr len -- len )                                  dup 0< IF abs over dup 1- c@ under type ELSE 0 THEN rot over    BEGIN  key decode  UNTIL                                        nip over - negate cur+ nip ;                                                                                                  Input:  keyboard                                                        PCkey PCkey? PCdecode PCaccept false [                                                                                  ' keyboard 5 + input !                                          \ Output: display                                 mod  24dec93py                                                                Output: display                                                   PCemit true PCcr PCtype PCdel PCpage PCat PCat? PCform noop     noop noop PCcuron PCcuroff PCcurleft PCcurrite PCclrline [                                                                    ' display 5 + output !                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          \ drive                                                28mar94py                                                                $10000000 | Constant b/dev                                         $40000 | Constant blk/dev                                                                                                    : drive   ( drv# -- )  dup dsetdrv drop blk/dev * offset ! ;    : >drive  ( block drv# -- block' ) blk/dev * + offset @ - ;     : drv?    ( block -- drv# )  offset @ + blk/dev / ;                                                                             : A:  0 drive  ;                : B:  1 drive  ;                : C:  2 drive  ;                : D:  3 drive  ;                : E:  4 drive  ;                : F:  5 drive  ;                : G:  6 drive  ;                : H:  7 drive  ;                                                                                                                                                                                                                \ PCr/w                                                25may03py                                                                | : r/werr  ( err# flag -- )                                        IF  -&34  ELSE  -&33  THEN  diskerr ;                       : PCr/w   ( File Pos Len Addr r/wf -- )  >r swap 2swap swap       dup 0= abort" no direct access!"                                BEGIN  dup filehandle @  dup 0< WHILE  drop                            dup r/w (open -&1037 case?                                      IF  dup r/o (open  THEN  throw                           REPEAT  >r dup >r filesize @ over u>                            0= IF  rdrop rdrop -5 r> r/werr  THEN                           0 r@ reposition-file drop r@ ?pos r> swap 2swap rot             dup 0>=  IF  drop r> r@  IF  fwrite  ELSE  fread  THEN                dup 0>=  IF  swap iorpos drop rdrop pause EXIT  THEN      THEN  rdrop r> r/werr ;                                       ' PCr/w IS BlockR/W                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             \ DOS access words                                     20aug95py                                                                Code dos@   ( addr -- x )       AX DOS) AX mov                                                  Next end-code macro 0 :@ T&P    Code dos!   ( x addr -- )       AX DOS) pop  AX pop                                             Next end-code macro 0 :ax T&P   Code dosw@  ( addr -- 16b )     AX DOS) AX movzx                                                Next end-code macro             Code dosw!  ( 16b a -- )        DX pop DX AX DOS) .w mov AX pop                                 Next end-code macro :dx :ax T&P Code dosc@  ( addr -- c )       .b AX DOS) AX movzx                                             Next end-code macro 0 :c@ T&P   Code dosc!  ( c addr -- )       DX pop  DL AX DOS) mov  AX pop                                  Next end-code macro :dx :ax T&P                                                                                                                                 \ Gemdos Primitives                                    20aug95py                                                                code int  here 1+ AL 0 A#) mov                                       HostSem A# AX mov  R: ] lock [                                  BP push  DI push  BX push  AX push                              SP BP mov  SI SP mov                                            $1F # AX bt  b IF  DX pop  DL AL mov  THEN                      $1C # AX bt  b IF  BX pop  THEN                                 $1E # AX bt  b IF  CX pop  THEN                                 $1D # AX bt  b IF  DX pop  THEN                                 $19 # AX bt  b IF  SI pop  THEN                                 $18 # AX bt  b IF  DI pop  THEN                                 $1B # AX bt  b IF  CX DX mov  $10 # CX shr  THEN                $1A # AX bt  b IF  SI DI mov  $10 # SI shr  THEN                AX AX movzx  BP SP xchg  BP push                                0 # int  here 1- swap !                                    \ Gemdos Primitives                                    20aug95py     SI pop  BP pop  :R S:  \ SS push  DS pop                        nb IF  $10 # BP btr  THEN                                       $10 # BP bt  b IF AX AX movzx  AX neg  ELSE                      $11 # BP bt  b IF 0<> IF -1 # push ELSE 0 # push THEN THEN      $12 # BP bt  b IF $10 # DX shl .w AX DX mov DX AX mov THEN      $13 # BP bt  b IF $10 # CX shl  .w DX CX mov  THEN              $14 # BP bt  b IF BX push  THEN                                 $16 # BP bt  b IF CX push  THEN                                 $15 # BP bt  b IF DX push  THEN                                 $17 # BP bt  b IF AX AX xor  THEN  THEN                        R: BX pop  DI pop  BP pop  ;c:  hostSem unlock ;                                                                           : bios    $16 int ;                                             : vbios   $10 int ;                                             : ms-dos  $21 int ;                                             \ file and drive operations                            31jul00py: fcreate  ( C$ attr -- handle/ior )       $60013C00 ms-dos ;   : fopen ( C$ mode -- handle/ior ) drop 4 swap $5001FF02 ms-dos ; \ : fopen ( C$ -- handle/ior ) 2 $A0013D00 ms-dos ;            : fclose   ( handle -- ior/0 )             $10813E00 ms-dos ;   : fread    ( addr len handle -- ior/len )  $70013F00 ms-dos ;   : fwrite   ( addr len handle -- ior/len )  $70014000 ms-dos ;   : fseek    ( pos handle mode -- ior/pos )  $D8054200 ms-dos ;   : dsetdrv  ( drive -- ior )                $20010E00 ms-dos ;   : dgetdrv  ( -- drive )        $00001900 ms-dos $FF and ;       : dattime ( -- dattime )                                          $00482C00 ms-dos drop [ 2 ] [FOR]  $100 /mod  [NEXT]            $00482A00 ms-dos drop $100 /mod $100 /mod                       &1980 - 4 << + 5 << + 5 << + 6 << + 6 << + nip ;              : time&date ( -- sec min hour day month year )  dattime           $40 /mod  $40 /mod  $20 /mod  $20 /mod  $10 /mod  &1980 + ;   \ recover code                                         25aug96py                                                                Label recover  AX push  0 # AX mov  here 4 -                          AX DS mov  AX ES mov  AX FS mov                                 CS AX mov  SS: AX 8 SP D) xchg                                  AX dumped $B cells + A#) mov                                    $75 # AX cmp  0=  IF  $10 # AX mov  THEN                        $13 # AX cmp  u>  IF  $13 # AX mov  THEN                        A: except' AX *4 i#) AX mov                                     SS: AX SP ) xchg  ret  end-code   >label stdDS                                                                            : DPMIidt! ( hander n -- )  dup $14 >= IF  2drop  EXIT  THEN      cells except' + ! ;                                                                                                                                                                                                                                           \ Startup code                                         06apr96py                                                                : !recover  DS@ stdDS !  recover  $10AF @ ! ;                   Code idt  AX push  AX push  AX push  SP ) sidt                       $E0000000 # AX mov  2 SP D) AX add  8 # SP add                  Next end-code                                              : idt! ( addr n -- )  CS@ 3 and  IF  DPMIidt!  EXIT  THEN         >r dup $FFFF0000 and $8E00 + swap                               $FFFF and CS@ $10 << + r> cells 2* idt + 2! ;                 here 0 vec! Assembler                                                ' Mroot 5 + A#) pop  ' FORTHstart 5 + A#) pop                   SP RP mov  ' Mroot 5 + A#) AX mov  9 cells AX D) AX mov         AX neg  RP AX I) SP lea                                         RP r0 A#) mov   SP s0 A#) mov                                   $10 SP D) UP lea  UP 0 UP D) mov   UP 4 UP D) mov               AHEAD  T \ branch over COLD's header                       \ PCkey? getkey                                        05apr96py                                                                $08 Constant #bs         $0D Constant #cr                       $0A Constant #lf         $1B Constant #esc                      $09 Constant #tab                                                                                                               : con!     ( 8b -- )     $20000200 ms-dos drop ;                : bell     ( -- )        7 con! ;                               : esc!     ( 8b -- )     #esc con! con! ;                       : esc[     ( 8b -- )     '[ esc! con! ;                                                                                         : PCkey?   ( -- fl )     $00021100 bios drop ;                                                                                  : PCkey    ( -- char )   curon                                    BEGIN  pause PCkey?  UNTIL curoff $00001000 bios $FFFF and ;                                                                  \ emit cr del page at at? type                         20aug95py                                                                Variable color  7 color !                                       \ : bg  color @ dup $88 and swap $70 and dup 4 >> or or 8 << ;                                                                  : PCemit   ( 8b -- )    sp@ 1 pctype drop ;                     : PCcr                  #lf sp@ 1 pctype drop ;                 : PCdel                 curleft  space  curleft ;               : PCpage                'J esc[ ;                               : PCat  ( row col -- )  swap 8 << + 0 $30000200 vbios drop ;    : PCat? ( -- row col )  0 $10200300 vbios drop                                          $100 /mod $FF and swap ;                : PCform ( -- rows cols )                                         $484 dosc@ 1+ $00000F00 vbios 8 >> ;                                                                                                                                                          \ PCtype PC Cursor operations                     mod  20aug95py                                                                : PCtype  1 fwrite drop pause ;                                                                                                 : PCcuron      ;                                                : PCcuroff     ;                                                : PCcurleft    -1 cur+ ;                                        : PCcurrite     1 cur+ ;                                        : PCclrline    row 0 at 'K esc[ ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               \ (bye                                                 20aug95py                                                                | Code (bye   $4C # AH mov  $21 # int  end-code                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \ OS Library load                                      14dec08pyVariable libs  NIL libs A!      \ links between library threads H 0 cells Constant :getlib      1 cells Constant :procaddr T                                                                    Code getlib ( addr len -- lib/0 )  DX pop  [IFDEF] :win32            SI push  DI push  BP push  SP BP mov                            sys-sp A#) SP mov  [ELSE]                                       SP -4 SI D) mov  -$10 # SP and   DX push  DX push  [THEN]       DX push  AX push  ' ftab 5 + A#) AX mov  :getlib AX D) call     [IFDEF] :win32  BP SP mov  BP pop  DI pop  SI pop               [ELSE]  -4 SI D) SP mov  [THEN]  Next end-code                                                                                                                                                                                                                                                                                                                                             \ OS Library load                                      14dec08py                                                                Code procaddr ( addr len lib -- addr/0 )  DX pop  CX pop             [IFDEF] :win32  SI push  DI push  BP push  SP BP mov            sys-sp A#) SP mov  [ELSE]                                       SP -4 SI D) mov  -$10 # SP and  CX push  [THEN]                 CX push  DX push  AX push                                       ' ftab 5 + A#) AX mov   :procaddr AX D) call                    [IFDEF] :win32  BP SP mov  BP pop  DI pop  SI pop               [ELSE]  -4 SI D) SP mov  [THEN]  Next end-code                                                                                                                                                                                                                                                                                                                                                                                                             \ OS Library load                                      10jan09py: @lib ( lib -- )  cell+ dup 3 cells + count getlib               dup 0= IF  over 3 cells + count type                                       true abort" Library not found!"  THEN  swap ! ;    : @proc ( lib addr -- )  over cell+ @ 0= IF  over @lib  THEN      tuck cell+ cell+ count rot cell+ @ procaddr dup 0=              IF  drop ." in library: " dup cell+ @ $10 + count type              ."  procedure: " 2 cells + count type cr                        true abort" procedure not found!"  THEN swap 10 - call! ; | : resolve-syms ( -- )  up@ dup @ up!                              [IFDEF] :win32  sys-sp @ r>  rp@ $40 - sys-sp !                         dup 5 - >r   swap >r 10 + @ @syms r> sys-sp !           [ELSE]  r> dup 5 - >r 10 + @ @syms  [THEN] up! ;            : @libs  libs LIST> dup cell+ off  2 cells +                      LIST> 10 - ['] resolve-syms swap call! ;                      | Code .call  R: AX call  next end-code macro :r :r T&P         \ push macros                                          23aug03py| Code .swap ( n1 n2 -- n2 n1 )  AX pop DX pop AX push DX push         Next end-code macro                                      | Code .int ( n -- )    0 BP D) pop        Next  end-code macro | Code .sfloat ( sf -- ) .fs 0 BP D) fstp  Next end-code macro  | Code .dfloat ( df -- ) .fl 0 BP D) fstp  Next end-code macro  | Code .save ( -- )  AX push  BP -4 SI D) mov   -4 SI D) SI lea        sys-sp A#) BP mov  Next end-code macro                   | Code .correct ( -- )  0 BP D) BP lea   Next end-code macro    | Code .sys-stack ( -- )  BP SI xchg  Next end-code macro       | Code .voidr ( -- )  R: BP SP mov  BP pop  lods  nop                  Next end-code macro :r :r T&P                            | Code .intr  ( -- )  R: BP SP mov  BP pop  nop   nop                  Next end-code macro :r :r T&P                            | Code .llr ( -- )  R: BP SP mov  BP pop  S: AX push                   DX AX mov  Next end-code :r :r T&P                       \ fp save and restore                                  05oct05pyCode fpush ( f.. -- )                                                fxam  ( fwait )  AX fstsw  $FD # AH and  $41 # AH cmp           0= IF  0 # -4 BP D) mov  -4 # BP add  Next  THEN                $B # AX shr  7 # AX and  7 # AX xor   1 AX D) CX lea            BEGIN  .fx -$C BP D) fstp  $C # BP sub  AX dec  0< UNTIL        CX -4 BP D) mov  -4 # BP add  Next  end-code               Code fppll ( -- f.. )  R: BP SP mov  S: AX push DX AX mov  R:        AHEAD  end-code                                            Code fppi ( -- f.. )  R:  BP SP mov  AHEAD  end-code            Code fppv ( -- f.. )  R:  BP SP mov  lods  THEN  THEN                CX pop  ?DO  .fx SP ) fld  $C # SP add                                       CX dec  0= UNTIL THEN  BP pop  Next end-code  Code fppf ( -- f.. )  R:  BP SP mov  lods                            CX pop  ?DO  .fx SP ) fld  $C # SP add   1 ST fxch                           CX dec  0= UNTIL THEN  BP pop  Next end-code  \ syscall compile primitives                           14dec08pyVariable s-offset               Variable direction              | Variable lastcorrect          | Variable thelib               Variable legacy                 Variable ind-call               | : !offset ( n -- )  direction @ 0= IF                                  negate cells s-offset +!  THEN  s-offset @ here 3 - c!     direction @    IF  cells s-offset +!  THEN ;                | : res,  ind-call @ IF  compile .call                              ELSE  compile resolve-syms  THEN ;                          | : (proc)  ( xt -- ) correct   compile .sys-stack res,             compile, compile ;  ind-call @ ?EXIT proc, ;                | : (fproc)  ( xt -- ) correct  compile .sys-stack compile fpush    res, compile, compile ; ind-call @ ?EXIT proc, ;                                                                                                                                                                                                            \ syscall compile primitives                           23aug03py: int ( -- )   compile .int     1 !offset ;  immediate restrict ' int Alias ptr                              immediate restrict : llong ( -- )  direction @ IF  compile .swap  THEN               compile int compile int ;                  immediate restrict : ints ( -- )  0 ?DO  ['] int execute LOOP ; immediate restrict : sf ( -- )    compile .sfloat  1 !offset ;  immediate restrict : df ( -- )    compile .dfloat  2 !offset ;  immediate restrict : (void) ( -- ) ['] .voidr (proc) ;          immediate restrict : (int)  ( -- ) ['] .intr  (proc) ;          immediate restrict : (llong) ( -- ) ['] .llr  (proc) ;          immediate restrict ' (int) Alias (ptr)                          immediate restrict : (fp)   ( -- ) ['] fppf  (fproc) ;          immediate restrict : (int/fp)      ['] fppi  (fproc) ;          immediate restrict : (void/fp)     ['] fppv  (fproc) ;          immediate restrict : (llong/fp) ( -- ) ['] fppll (fproc) ;      immediate restrict \ OS Library load                                      22dec08py: <rev> ( -- )  compile .correct  here 3 - lastcorrect !          direction on ;                             immediate restrict [IFDEF] :osx  | Variable aligncorrect  [THEN]                   | : correct ( -- )  direction @ 0=                                  IF   compile .correct  0 !offset                                ELSE s-offset @ negate lastcorrect @ c! THEN                [ [IFDEF] :osx ]                                                    s-offset @ abs cell+ negate $F and negate aligncorrect @ c! [ [THEN] ] s-offset off ;                                       : proc:  ind-call off s-offset off direction off                  : compile .save                                                 [ [IFDEF] :osx ]                                                  compile .correct  here 3 - aligncorrect ! [ [THEN] ]            legacy @ IF  legacy @ 0< IF  compile <rev>  THEN                             swap compile ints compile (int/fp)  THEN ;     \ OS Library load                                      14dec08py                                                                | : proc, ( -- ) here dup >r thelib @ 2 cells + dup @ A, !          thelib @ dup A, bl word c@ 1+ allot cell+ @ warning @ or        IF  thelib @ r@ @proc  THEN  rdrop ;                        : library   ( -- ) Create  here libs @ A, dup libs ! 0 ,          0 A, 0 A, bl word  c@ 1+ allot drop  DOES>  thelib !  proc: ; : depends  libs @ 3 cells + dup @ here rot ! A, ' >body A, ;    | : @depend  ( addr -- ) dup 3 cells + LIST>  cell+ @ @syms ;   : @syms ( lib -- )  dup cell+ @ IF  drop  EXIT  THEN              dup 3 cells + @  IF  @depend  THEN                              dup @lib dup thelib ! 2 cells + LIST> thelib @ swap @proc ;                                                                                                                                                                                                                                                                   \ OS/2 Library initializing                           114dec08py                                                                library doscalls doscalls       library viocalls viocalls       1 doscalls DosSetDefaultDisk   #220                             4 doscalls DosSetFilePtr       #256                             1 doscalls DosClose            #257                             8 doscalls DosOpen             #273                             2 doscalls DosQueryCurrentDisk #275                             4 doscalls DosRead             #281                             4 doscalls DosWrite            #282                                                                                             : dsetdrv  ( drive -- ior )   DosSetDefaultDisk ;               : dgetdrv  ( -- drive )       0 sp@ sp@ DosQueryCurrentDisk       2drop ;                                                       : dattime ( -- dattime )   $3D1762F8 ;                          : !recover ;                                                    \ OS/2 file and drive operations                       24may97py                                                                : /ior ( ret ior -- ret/-ior ) dup IF negate swap THEN drop ;   $C2 Value openmode                                              Variable len    Variable action                                 : fcreate  ( C$ attr -- handle/ior )  drop                        >r 0 sp@ >r 0 openmode $12 0 0 action  r> r>  DosOpen /ior ;  : fopen    ( C$ mode -- handle/ior )  $C0 or >r >r                0 sp@ r> swap >r 0 swap $01 0 0 action  r> r>  DosOpen /ior ; : fclose   ( handle -- ior/0 )  DosClose ;                      : fread    ( addr len handle -- ior/len )                         >r len -rot swap r> DosRead  len @ swap /ior ;                : fwrite   ( addr len handle -- ior/len )                         >r len -rot swap r> DosWrite len @ swap /ior ;                : fseek    ( pos handle mode -- ior/pos )                         len swap 2swap DosSetFilePtr len @ swap /ior ;                \ startup code                                         14jan01py                                                                here 0 vec! Assembler  DX pop     ' Mroot      5 + A#) pop           ' FORTHstart 5 + A#) pop     ' ftab       5 + A#) pop           SP sys-sp A#) mov                                               ' Mroot 5 + A#) AX mov  cell AX D) AX mov                       AX ) AX add  -8 # AX add  AX RP mov                             ' Mroot 5 + A#) AX mov  9 cells AX D) AX mov                    AX neg  RP AX I) SP lea                                         RP r0 A#) mov   SP s0 A#) mov                                   $10 SP D) UP lea  UP 0 UP D) mov   UP 4 UP D) mov               AHEAD  T \ branch over COLD's header                                                                                                                                                                                                                                                                                       \ function table support                               20aug95py                                                                H                                                               2 cells Constant :type          3 cells Constant :getkey        4 cells Constant :at?           5 cells Constant :at            6 cells Constant :form                                          7 cells Constant :bye           8 cells Constant :recovery      T                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               \ con! esc!                                            14dec08py                                                                $08 Constant #bs         $0D Constant #cr                       $0A Constant #lf         $1B Constant #esc                      $09 Constant #tab        $07 Constant #bell                                                                                     : con!     ( 8b -- )     PCemit ;                               : esc!     ( 8b -- )     #esc con! con! ;                       : esc[     ( 8b -- )     '[ esc! con! ;                                                                                         \ (bye                                                 20aug95py| Code (bye ( err# -- )                                                SP -4 SI D) mov  -$10 # SP and   AX push AX push AX push        AX push  ' ftab 5 + A#) AX mov  :bye  AX D) call                -4 SI D) SP mov  AX pop  Next end-code                                                                                   \ PCkey? getkey                                        14dec08py                                                                Variable pending                                                Variable kbshift                                                                                                                : PCkey? ( -- flag )  pending @ 0=                                IF  0 PCgetkey pending !  THEN  pending @ 0<> ;               : PCkey ( -- key )  curon                                         BEGIN  pause PCkey? 0=  WHILE                                          up@ dup @ =  IF  true PCgetkey pending !  THEN                  0 &50 idle   REPEAT  curoff                              pending @ dup $10 rshift kbshift ! $FFFF and pending off ;                                                                                                                                                                                                                                                                    \ emit cr del page at at? type                         06apr96py                                                                Variable color  7 color !                                       | : bg  color @ dup $88 and swap $70 and dup 4 >> or or 8 << ;  : PCemit   ( 8b -- )    sp@ 1 PCtype drop ;                     : bell                  7 emit ;                                | Create crlf  #cr c, #lf c,                                    : PCcr                  crlf 2 PCtype ;                         : PCdel                 curleft  space  curleft ;               : PCpage                'J esc[ ;                                                                                               : PCcuron      ;                                                : PCcuroff     ;                                                : PCcurleft    -1 cur+ ;                                        : PCcurrite     1 cur+ ;                                        : PCclrline    row 0 at 'K esc[ ;                               \ PCtype PC Cursor operations                     mod  14dec08pyCode PCtype   ( addr len -- )  DX pop                                SP -4 SI D) mov  -$10 # SP and   DX push  DX push               DX push  AX push  ' ftab 5 + A#) AX mov  :type AX D) call       -4 SI D) SP mov  AX pop  Next end-code                     Code PCat     ( row col -- )  DX pop                                 SP -4 SI D) mov  -$10 # SP and   DX push  DX push               DX push  AX push  ' ftab 5 + A#) AX mov  :at   AX D) call       -4 SI D) SP mov  AX pop  Next end-code                     Code PCat? ( -- row col )  AX push                                   SP -4 SI D) mov  -$10 # SP and                                  ' ftab 5 + A#) AX mov  :at?  AX D) call                         -4 SI D) SP mov                                                 AX DX mov  DX $10 # shr  DX push  $FFFF # AX and                Next end-code                                                                                                              \ PCtype PC Cursor operations                     mod  14dec08pyCode PCform ( -- row col )  AX push                                  SP -4 SI D) mov  -$10 # SP and                                  ' ftab 5 + A#) AX mov  :form AX D) call                         -4 SI D) SP mov                                                 AX DX mov  DX $10 # shr  DX push  $FFFF # AX and                Next end-code                                              Code PCgetkey   ( flag -- key )                                      SP -4 SI D) mov  -$10 # SP and   AX push  AX push  AX push      AX push  ' ftab 5 + A#) AX mov  :getkey AX D) call              -4 SI D) SP mov  Next end-code                                                                                                                                                                                                                                                                                                                                                             \ Linux Library initializing                           23jan10py[IFDEF] :glibc                                                  library libc libc.so.6          library libm libm.so.6          libc errno                      (int) __errno_location          [ELSE] [IFDEF] :osx                                             library libc libc.dylib         library libm libm.dylib         libc (errno                     (int) errno                     : errno  ['] (errno dup 2- wx@ + &11 - cfa@ ;                   [ELSE] [IFDEF] :bsd                                             library libc libc.so            library libm libm.so            libc (errno                     (int) errno                     : errno  ['] (errno dup 2- wx@ + &11 - cfa@ ;                   [ELSE]                                                          library libc libc.so.5          library libm libm.so.5          libc errno                      (int) __errno_location          [THEN]  [THEN]  [THEN]                                          \ Linux Library functions                              24jan10pyclearstack libc _open           int int int (int) open          libc _close                  int (int) close                    libc _read           int int int (int) read                     libc _write          int int int (int) write                    [IFDEF] :bsd  libc _lseek  int llong int (int) lseek            [ELSE] libc _lseek   int llong int (int) lseek64 [THEN]         libc select    <rev> int int int int int (int) select                             ( timeout efds wfds rfds n -- n' )            \ libc setitimer <rev> int int int (int) setitimer                                ( ovalue value which -- r )                   libc _malloc                 int (int) malloc ( size -- addr )  libc _free                   int (int) free ( addr -- r )       libc gettimeofday        int int (int) gettimeofday ( tv tz -- )libc localtime               int (int) localtime ( tv -- tm )                                                                   \ Linux file and drive operations                      24jan10py                                                                : /ior ( ret -- ret/-ior ) dup -1 =                               IF drop errno noop @ negate  THEN ;                           : fcreate  ( C$ attr -- handle/ior )                              dup >r -5 and $240 or r> 4 and  IF  $1FF  ELSE  $1B6  THEN                                                       _open /ior ; : fopen    ( C$ mode -- handle/ior ) -5 and   $1B6 _open /ior ; : fclose   ( handle -- ior/0 )                    _close /ior ; : fread    ( addr len handle -- ior/len )    -rot _read  /ior ; : fwrite   ( addr len handle -- ior/len )    -rot _write /ior ; : fseek ( pos hnd mode -- ior/pos ) >r swap 0 r> _lseek /ior ;                                                                                                                                                                                                                                                                  \ Linux file and drive operations                      21jun09py                                                                : dsetdrv  ( drive -- ior )   drop 0 ;                          : dgetdrv  ( -- drive )       0 ;                                                                                               Create timeval   0 , 0 ,                                        Create timezone  0 , 0 ,                                                                                                        : dattime ( -- dattime )                                          timeval timezone gettimeofday drop                              timeval localtime   @+ @+ @+ @+ @+ @+                           drop &80 - 4 << + 1+ 5 << + 5 << + 6 << + 6 << + ;            : time&date ( -- sec min hour day month year )  dattime           $40 /mod  $40 /mod  $20 /mod  $20 /mod  $10 /mod  &1980 + ;                                                                   : !recover ;                                                    \ emit cr del page at at? type                         06apr96py                                                                Variable color  7 color !                                       : PCemit   ( 8b -- )    sp@ 1 PCtype drop ;                     : bell                  7 emit ;                                : PCcr                  #lf emit ;                              : PCdel                 curleft  space  curleft ;               : PCpage                '2 esc[ 'J emit  0 0 at ;                                                                               : PCcuron      ;                                                : PCcuroff     ;                                                : PCcurleft    -1 cur+ ;                                        : PCcurrite     1 cur+ ;                                        : PCclrline    row 0 at 'K esc[ row 0 at ;                                                                                                                                                      \ Linux exception handling                             06feb00py                                                                Code recovering  R: 4 SP D) AX mov                                   'UP A#) UP mov   ' ftab 5 + A#) CX mov                           8 cells CX D) CX mov                                            2 cells CX D) SP mov                                            4 cells CX D) SI mov                                           $D cells CX D) CX mov  CX CX test  0<> IF                           .b 0 # 4 CX D) mov  CX ) frstor  THEN                       AX AX test  0= IF  AX dec  THEN                                 ' throw rel) jmp  end-code                                 : !signals ['] recovering ftab 8 cells + @ ! ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  \ Win32 library initialization                         19jun02py                                                                library kernel32 kernel32                                       library user32 user32                                                                                                           Variable errno  -1 errno !                                                                                                      kernel32 fopen int int (int) _lopen                             kernel32 _lcreat int int (int) _lcreat                          kernel32 fclose int (int) _lclose                               kernel32 _hwrite <rev> int int int (int) _hwrite                kernel32 _hread <rev> int int int (int) _hread                  kernel32 _llseek <rev> int int int (int) _llseek                                                                                kernel32 GetSystemTime int (void) GetSystemTime                                                                                 \ Win32 file and drive operations                      19jun02py                                                                : /ior ( ret -- ret/-ior ) dup -1 =                               IF drop errno noop @ negate THEN ;                            2 Value openmode                                                                                                                : fcreate  ( C$ attr -- handle/ior )  drop 0 _lcreat ;          \ : fopen    ( C$ mode -- handle/ior )  _lopen ;                \ : fclose   ( handle -- ior/0 )   _lclose ;                    : fread    ( addr len handle -- ior/len )                         >r swap r> _hread ;                                           : fwrite   ( addr len handle -- ior/len )                         >r swap r> _hwrite ;                                          : fseek    ( pos handle mode -- ior/pos )                         -rot _llseek ;                                                                                                                \ Win32 file and drive operations                      31jul00py                                                                : dsetdrv  ( drive -- ior )   drop 0 ;                          : dgetdrv  ( -- drive )       0 ;                                                                                               | Create systime $10 allot                                                                                                      : dattime ( -- dattime )                                          systime GetSystemTime                                           systime w@+ w@+ 2+ w@+ w@+ w@+ w@                               swap 6 << + swap &12 << + swap &17 << + swap &22 << + swap      &1980 - &26 << + ;                                            : time&date ( -- sec min hour day month year )  dattime           $40 /mod  $40 /mod  $20 /mod  $20 /mod  $10 /mod  &1980 + ;                                                                   : !recover ;                                                    \ Signal handling                                      24jan97py                                                                : !signals ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    \ startup code                                         14jan01py                                                                here 0 vec! Assembler  DX pop     ' Mroot      5 + A#) pop           ' FORTHstart 5 + A#) pop     ' ftab       5 + A#) pop      \     ' Mroot 5 + A#) AX mov  cell AX D) AX mov  AX ) AX add         SP AX mov                                                       -8 # AX add  AX RP mov                                          ' Mroot 5 + A#) AX mov  9 cells AX D) AX mov                    AX neg  RP AX I) SP lea                                         RP r0 A#) mov   SP s0 A#) mov                                   $10 SP D) UP lea  UP 0 UP D) mov   UP 4 UP D) mov               AHEAD  T \ branch over COLD's header                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       \ T&P: creates literal macros, defined in TARGET.SCR   20jun01py$00 T&P: :none  $01 T&P: :ax    $02 T&P: :dx    $03 T&P: :dx>   $04 T&P: :over  $05 T&P: :f     $06 T&P: :?     $07 T&P: :+loop $08 T&P: :lit   $09 T&P: :user  $0A T&P: :suser $0B T&P: :cdx   $0C T&P: :q+    $0D T&P: :i     $0E T&P: :ovar  $0F T&P: :svar  $12 T&P: :+     $22 T&P: :-     $32 T&P: :or    $42 T&P: :and   $52 T&P: :xor                                                   $69 T&P: :c!    $71 T&P: :#+c@  $72 T&P: :!     $73 T&P: :#!    $74 T&P: :ic@   $75 T&P: :#c@>  $76 T&P: :#c@   $77 T&P: :#@>   $78 T&P: :#@    $79 T&P: :user@ $7A T&P: :susr@ $7B T&P: :ovar@ $7C T&P: :svar@ $7D T&P: :i@    $7E T&P: :@     $7F T&P: :c@    $18 T&P: :#+    $28 T&P: :#-    $38 T&P: :#|    $48 T&P: :#&    $58 T&P: :#^    $6C T&P: :q+@   $6D T&P: :+@                    $61 T&P: :#@+   $62 T&P: :#@-   $63 T&P: :#@|   $64 T&P: :#@&   $65 T&P: :#@^   $66 T&P: :#+@   $67 T&P: :#>    $68 T&P: :##    $80 T&P: :r     $C0 T&P: :s     1 $A +thru                      \ opttab                                               20jun01pyCreate opttab   Assembler  BEGIN                                BEGIN  :#>   c,  0 c, \ Dummy                                   :#+   c, :+     c,   1 c, 5 c, 3 c, 6 c,  AX pop  0 L# AX add   :#-   c, :-     c,   1 c, 5 c, 4 c, 6 c,  AX pop  0 L# AX sub   :#|   c, :or    c,   1 c, 5 c, 3 c, 6 c,  AX pop  0 L# AX or    :#&   c, :and   c,   1 c, 5 c, 3 c, 6 c,  AX pop  0 L# AX and   :#^   c, :xor   c,   1 c, 5 c, 3 c, 6 c,  AX pop  0 L# AX xor   :ax   c, :!     c,   1 c, 5 c, 2 c, 6 c,  0 #) pop              :#@>  c, :@     c,   0 c, 5 c, 2 c, 5 c,  0 #) AX mov           :#c@> c, :c@    c,   2 c, 5 c, 3 c, 7 c,  .b 0 #) AX movzx      :#>   c, :lit   c,   0 c, 5 c, 1 c, 5 c,  0 L# push             0     c, :ax    c,   0 c, 5 c, 1 c, 5 c,  0 L# push             0     c, :cdx   c,   1 c, 5 c, 3 c, 6 c,  AX pop  0 L# AX cmp   0     c, :dx>   c,   1 c, 5 c, 3 c, 6 c,  AX pop  0 # DX mov    0     c, :+loop c,   1 c, 5 c, 2 c, 6 c,  0 L# BX add   THEN    \ opttab Fortsetzung                                   20jun01pyBEGIN  :lit  c,  0 c, \ Dummy                                   :#+   c, :+     c,  -1 c, 6 c, 3 c, 5 c,  0 L# AX add           :#-   c, :-     c,  -1 c, 6 c, 4 c, 5 c,  0 L# AX sub           :#|   c, :or    c,  -1 c, 6 c, 3 c, 5 c,  0 L# AX or            :#&   c, :and   c,  -1 c, 6 c, 3 c, 5 c,  0 L# AX and           :#^   c, :xor   c,  -1 c, 6 c, 3 c, 5 c,  0 L# AX xor           :ax   c, :!     c,  -1 c, 6 c, 2 c, 5 c,  AX 0 #) mov           :#@   c, :@     c,   0 c, 5 c, 2 c, 5 c,  0 #) AX mov           :#c@  c, :c@    c,   2 c, 5 c, 3 c, 7 c,  .b 0 #) AX movzx      0     c, :cdx   c,  -1 c, 6 c, 3 c, 5 c,  0 L# AX cmp           :#>   c, :lit   c,   0 c, 5 c, 1 c, 5 c,  0 L# push             0     c, :ax    c,   0 c, 5 c, 1 c, 5 c,  0 L# push             0     c, :dx    c,   1 c, 6 c, 1 c, 7 c,  AX DX mov  0 # AX mov 0     c, :dx>   c,   0 c, 5 c, 2 c, 5 c,  0 # DX mov            0     c, :+loop c,   0 c, 6 c, 3 c, 6 c,  0 L# BX add  THEN     \ opttab Fortsetzung                                   20jun01py                                                                BEGIN  :ax   c, 0 c,                                            0     c, :dx>   c,   0 c, 1 c, 2 c, 1 c,  DX pop                :#>   c, :lit   c,   0 c, 1 c, 1 c, 0 c,                        0     c, :ax    c,   0 c, 1 c, 1 c, 0 c,  THEN                  BEGIN  :dx   c, 0 c,                                            0 c,  :!     c,   0 c, 1 c, 2 c, 2 c,  DX AX ) mov              0 c,  :dx    c,   0 c, 1 c, 1 c, 0 c,                           0 c,  :cdx   c,   0 c, 1 c, 1 c, 0 c,  THEN                                                                                     BEGIN  :@    c, 0 c,                                            0 c,  :?     c,   0 c, 2 c, 2 c, 3 c,  0 # AX ) cmp             0 c,  :f     c,   0 c, 2 c, 2 c, 3 c,  0 # AX ) cmp             0 c,  :ax    c,   0 c, 2 c, 1 c, 2 c,  AX ) push                0 c,  :dx>   c,   0 c, 2 c, 2 c, 2 c,  AX ) DX mov  THEN        \ opttab Fortsetzung                                   20jun01py                                                                BEGIN  :#@   c, 0 c,                                            :#@+ c, :+     c,   0 c, 6 c, 3 c, 6 c,  0 #) AX add            :#@- c, :-     c,   0 c, 6 c, 4 c, 6 c,  0 #) AX sub            :#@| c, :or    c,   0 c, 6 c, 3 c, 6 c,  0 #) AX or             :#@& c, :and   c,   0 c, 6 c, 3 c, 6 c,  0 #) AX and            :#@^ c, :xor   c,   0 c, 6 c, 3 c, 6 c,  0 #) AX xor            0    c, :cdx   c,   0 c, 6 c, 3 c, 6 c,  0 #) AX cmp            0    c, :?     c,   1 c, 5 c, 2 c, 7 c,  0 # 0 #) cmp           0    c, :f     c,   1 c, 5 c, 2 c, 7 c,  0 # 0 #) cmp           0    c, :ax    c,   1 c, 5 c, 1 c, 6 c,  0 #) push  THEN                                                                                                                                                                                                                                                                        \ opttab Fortsetzung                                   20jun01py                                                                BEGIN  :#c@   c, 0 c,                                           0 c, :? c,  -1 c, 7 c, 2 c, 7 c, .b 0 # 0 #) cmp                0 c, :f c,  -1 c, 7 c, 2 c, 7 c, .b 0 # 0 #) cmp  THEN          BEGIN  :#+   c, 0 c,                                            :#+c@ c, :c@   c,   2 c, 5 c, 3 c, 7 c,  .b 0 AX L) AX movzx    :#+@  c, :@    c,   1 c, 5 c, 2 c, 6 c,  0 AX L) AX mov         :ax   c, :!    c,   1 c, 5 c, 2 c, 6 c,  0 AX L) pop  THEN      BEGIN  :#c@>  c, 0 c,                                           0 c, :? c,  -1 c, 7 c, 2 c, 7 c, .b 0 # 0 #) cmp                0 c, :f c,  -1 c, 7 c, 2 c, 7 c, .b 0 # 0 #) cmp  THEN          BEGIN  :ic@   c, 0 c,                                           0 c, :? c,  -1 c, 4 c, 2 c, 4 c,  .b 0 # AX BX i) cmp           0 c, :f c,  -1 c, 4 c, 2 c, 4 c,  .b 0 # AX BX i) cmp  THEN                                                                     \ opttab Fortsetzung                                   20jun01py                                                                BEGIN  :#@>  c, 0 c,                                            :#@+ c, :+     c,   2 c, 5 c, 3 c, 7 c,  AX pop  0 #) AX add    :#@- c, :-     c,   2 c, 5 c, 4 c, 7 c,  AX pop  0 #) AX sub    :#@| c, :or    c,   2 c, 5 c, 3 c, 7 c,  AX pop  0 #) AX or     :#@& c, :and   c,   2 c, 5 c, 3 c, 7 c,  AX pop  0 #) AX and    :#@^ c, :xor   c,   2 c, 5 c, 3 c, 7 c,  AX pop  0 #) AX xor    0    c, :cdx   c,   2 c, 5 c, 3 c, 7 c,  AX pop  0 #) AX cmp    0    c, :?     c,   1 c, 5 c, 2 c, 7 c,  0 # 0 #) cmp           0    c, :f     c,   1 c, 5 c, 2 c, 7 c,  0 # 0 #) cmp           0    c, :ax    c,   1 c, 5 c, 1 c, 6 c,  0 #) push  THEN        BEGIN  :dx>  c, 0 c,                                            0    c, :ax    c,   0 c, 2 c, 1 c, 1 c,  DX push                0    c, :!     c,   0 c, 2 c, 2 c, 2 c,  DX ) pop               0    c, :dx>   c,   0 c, 2 c, 2 c, 0 c,  THEN                   \ opttab Fortsetzung                                   20jun01pyBEGIN  :q+   c, 0 c,                                            :q+@ c, :@     c,   0 c, 3 c, 2 c, 3 c,  0 AX D) AX mov         :ax  c, :!     c,   0 c, 3 c, 2 c, 3 c,  0 AX D) pop  THEN                                                                      BEGIN  :+    c, 0 c,                                            :+@  c, :@     c,   0 c, 2 c, 2 c, 3 c,  AX DX I) AX mov        0    c, :c@    c,   0 c, 2 c, 3 c, 4 c,  .b AX DX I) AX movzx   :ax  c, :!     c,   0 c, 2 c, 2 c, 3 c,  AX DX I) pop  THEN                                                                     :#^  :#|  :#&  :#-  :#+   :xor :or  :and :-   :+                9 [FOR]  BEGIN BUT  c, 0 c,                                     :f :?  1 [FOR] 0 c, c,   0 c, 0 c, 2 c, 0 c, [NEXT] THEN [NEXT]                                                                                                                                                                                                 \ opttab Fortsetzung                                   04nov01py                                                                BEGIN  :over c, 0 c,                                            0 c,  :?    c,   0 c, 4 c, 2 c, 5 c,  0 # 0 SP D) cmp           0 c,  :f    c,   0 c, 4 c, 2 c, 5 c,  0 # 0 SP D) cmp           0 c,  :+loop c,  0 c, 4 c, 2 c, 4 c,  0 SP D) BX add            0 c,  :dx>  c,   0 c, 4 c, 2 c, 4 c,  0 SP D) DX mov   THEN     BEGIN  :i    c, 0 c,                                            :ax   c, :!   c,   0 c, 2 c, 2 c, 3 c,  AX BX I) pop            :ax   c, :c!  c,   0 c, 2 c, 3 c, 4 c,  DX pop  DL AX BX I) mov :ic@  c, :c@  c,   0 c, 2 c, 3 c, 4 c,  .b AX BX i) ax movzx    :i@   c, :@   c,   0 c, 2 c, 2 c, 3 c,  AX BX i) ax mov  THEN                                                                                                                                                                                                                                                                   \ opttab Rest                                          20jun01pyBEGIN  :user c, 0 c,                                            :user@ c, :@     c,   0 c, 6 c, 2 c, 6 c,  0 UP L) AX mov       :ax    c, :!     c,   0 c, 6 c, 2 c, 6 c,  0 UP L) pop  THEN    BEGIN  :user@ c, 0 c,                                           :f :? 1 [FOR] 0 c, w, 6 c, 2 c, 7 c,  0 # 0 UP L) cmp [NEXT]    0 c,  :ax  c,   0 c, 6 c, 1 c, 6 c,  0 UP L) push               0 c,  :dx> c,   0 c, 6 c, 2 c, 6 c,  0 UP L) DX mov  THEN       BEGIN  :suser c, 0 c,                                           :susr@ c, :@     c,   0 c, 3 c, 2 c, 3 c,  0 UP D) AX mov       :ax    c, :!     c,   0 c, 3 c, 2 c, 3 c,  0 UP D) pop  THEN    BEGIN  :susr@ c, 0 c,                                           :f :? 1 [FOR] 0 c, w, 3 c, 2 c, 4 c,  0 # 0 UP D) cmp [NEXT]    0 c,  :ax  c,   0 c, 3 c, 1 c, 3 c,  0 UP D) push               0 c,  :dx> c,   0 c, 3 c, 2 c, 3 c,  0 UP D) DX mov  THEN                                                                       \ opttab Rest                                          20jun01pyBEGIN  :ovar c, 0 c,                                            :ovar@ c, :@     c,   0 c, 6 c, 2 c, 6 c,  0 OP L) AX mov       :ax    c, :!     c,   0 c, 6 c, 2 c, 6 c,  0 OP L) pop  THEN    BEGIN  :ovar@ c, 0 c,                                           :f :? 1 [FOR] 0 c, w, 6 c, 2 c, 7 c,  0 # 0 OP L) cmp [NEXT]    0 c,  :ax  c,   0 c, 6 c, 1 c, 6 c,  0 OP L) push               0 c,  :dx> c,   0 c, 6 c, 2 c, 6 c,  0 OP L) DX mov  THEN       BEGIN  :svar c, 0 c,                                            :svar@ c, :@     c,   0 c, 3 c, 2 c, 3 c,  0 OP D) AX mov       :ax    c, :!     c,   0 c, 3 c, 2 c, 3 c,  0 OP D) pop  THEN    BEGIN  :svar@ c, 0 c,                                           :f :? 1 [FOR] 0 c, w, 3 c, 2 c, 4 c,  0 # 0 OP D) cmp [NEXT]    0 c,  :ax  c,   0 c, 3 c, 1 c, 3 c,  0 OP D) push               0 c,  :dx> c,   0 c, 3 c, 2 c, 3 c,  0 OP D) DX mov  THEN       BEGIN  end-code  swap - Constant #opt