win32forth-cvs — CVS Commit List

[Win32forth-cvs] win32forth/src/kernel fkernel.f,1.14,1.15

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/kernel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10104/win32forth/src/kernel

Modified Files:
	fkernel.f 
Log Message:
gah: modified SEE to detect the difference between EXIT plus and ; EXITM and ;M. Made _EXIT and EXITP aliases of UNNEST and UNNESTP

Index: fkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/kernel/fkernel.f,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** fkernel.f	2 Jun 2005 21:14:55 -0000	1.14
--- fkernel.f	6 Jun 2005 09:44:39 -0000	1.15
***************
*** 125,132 ****
                  next    c;
  
! NCODE _EXIT     ( -- )          \ exit the current Forth definition
!                 mov     esi, 0 [ebp]
!                 add     ebp, # 4
!                 next    c;
  
  NCODE LIT       ( -- n )        \ push the literal value following LIT in the
--- 125,129 ----
                  next    c;
  
! ' UNNEST ALIAS _EXIT
  
  NCODE LIT       ( -- n )        \ push the literal value following LIT in the
***************
*** 2009,2013 ****
    THROW_MSGS LINK, THROW_WINERR              , ," Windows DLL error"
    THROW_MSGS LINK, THROW_STACKCHG            , ," stack changed"
!   THROW_MSGS LINK, THROW_METHEXIT            , ," can't use EXIT in a method"
    THROW_MSGS LINK, THROW_METHDOES>           , ," can't use DOES> in a method"
    THROW_MSGS LINK, THROW_METH;M              , ," method must end with ;M"
--- 2006,2010 ----
    THROW_MSGS LINK, THROW_WINERR              , ," Windows DLL error"
    THROW_MSGS LINK, THROW_STACKCHG            , ," stack changed"
!   THROW_MSGS LINK, THROW_METHEXIT            , ," can't be used in a method"
    THROW_MSGS LINK, THROW_METHDOES>           , ," can't use DOES> in a method"
    THROW_MSGS LINK, THROW_METH;M              , ," method must end with ;M"
***************
*** 2457,2461 ****
                  dup to -ve-num? negate /string
                  0 0 2swap >number nip
!                 if false _exit then             \ leave if not all converted
                  -ve-num? if dnegate then true ;
  
--- 2454,2458 ----
                  dup to -ve-num? negate /string
                  0 0 2swap >number nip
!                 if false exit then             \ leave if not all converted
                  -ve-num? if dnegate then true ;
  
***************
*** 4934,4944 ****
                  next    c;
  
! NCODE EXITP     ( -- )                  \ exit the current Forth definition, remove parms
!                 mov     ebp, LP [UP]
!                 mov     eax, 0 [ebp]
!                 mov     esi, 4 [ebp]
!                 mov     LP [UP], eax
!                 add     ebp, # 8
!                 next    c;
  
  NCODE INIT-LOCALS ( loc1 loc2 ... -- )
--- 4931,4935 ----
                  next    c;
  
! ' UNNESTP ALIAS EXITP
  
  NCODE INIT-LOCALS ( loc1 loc2 ... -- )
***************
*** 5655,5664 ****
                  EXIT_A
                  PARMS
!                 IF      COMPILE EXITP
!                 ELSE    COMPILE _EXIT
                  THEN    ; IMMEDIATE
  
  : ?EXIT         ( F1 -- )
!                 EXIT_A
                  [COMPILE]  IF
                  [COMPILE]  EXIT
--- 5646,5655 ----
                  EXIT_A
                  PARMS
!                 IF      COMPILE UNNESTP
!                 ELSE    COMPILE UNNEST
                  THEN    ; IMMEDIATE
  
  : ?EXIT         ( F1 -- )
! \                EXIT_A
                  [COMPILE]  IF
                  [COMPILE]  EXIT
***************
*** 5710,5714 ****
                  IF      COMPILE UNNESTP
                  ELSE    COMPILE UNNEST
!                 THEN    [COMPILE] [ PARMS-INIT DO-;CHAIN ; IMMEDIATE
  
  
--- 5701,5705 ----
                  IF      COMPILE UNNESTP
                  ELSE    COMPILE UNNEST
!                 THEN ( EXIT_B )  [COMPILE] [ PARMS-INIT DO-;CHAIN ; IMMEDIATE
  
  
***************
*** 5719,5722 ****
--- 5710,5714 ----
  in-application
  
+  ' UNNEST        RESOLVES EXIT
  ' CONSTANT      RESOLVES CONSTANT 
  ' THROW         RESOLVES THROW
***************
*** 5732,5733 ****
--- 5724,5726 ----
  ' ?THROW        RESOLVES ?THROW
  ' WARNMSG       RESOLVES WARNMSG
+ 

[Win32forth-cvs] win32forth/src SEE.F,1.2,1.3

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10104/win32forth/src

Modified Files:
	SEE.F 
Log Message:
gah: modified SEE to detect the difference between EXIT plus and ; EXITM and ;M. Made _EXIT and EXITP aliases of UNNEST and UNNESTP

Index: SEE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/SEE.F,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** SEE.F	1 Jun 2005 09:55:12 -0000	1.2
--- SEE.F	6 Jun 2005 09:44:39 -0000	1.3
***************
*** 142,182 ****
                  then    ;
  
  : .execution-class  ( ip cfa -- ip' )
      case
!         ['] lit         of cell+ ." lit "   .word                   endof
!         ['] (&of-local) of cell+ ." &OF "   .word                   endof
!         ['] (&of-VALUE) of cell+ ." &OF "   .word                   endof
!             &flit       of cell+ ." flit "  .float                  endof
!         ['] (is)        of cell+ ." (is) "  .word                   endof
!         ['] (.")        of ." ."        .string                     endof
!         ['] (S")        of ." S"        .string                     endof
!         ['] (Z")        of ." Z"        .string                     endof
!         ['] (C")        of ." C"        .string                     endof
!         ['] (abort")    of ." ABORT"    .string                     endof
!         ['] ?branch     of      d_cr ." IF      " +tab  cell+ cell+ endof
!         ['] -?branch    of      d_cr ." -IF     " +tab  cell+ cell+ endof        
!         ['] branch      of -tab d_cr ." ELSE    " +tab  cell+ cell+ endof
!         ['] (do)        of      d_cr ." DO      " +tab  cell+ cell+ endof
!         ['] (?do)       of      d_cr ." ?DO     " +tab  cell+ cell+ endof
!         ['] (loop)      of -tab d_cr ." LOOP    "       cell+ cell+ endof
!         ['] (+loop)     of -tab d_cr ." +LOOP   "       cell+ cell+ endof
!         ['] _case       of      d_cr ." CASE    " +tab  cell+       endof
!         ['] _of         of      d_cr ." OF      " +tab  cell+ cell+ endof
          ['] _endof      of  tab      ." ENDOF   " -tab  d_cr
!                                                         cell+ cell+ endof
!         ['] _endcase    of -tab d_cr ." ENDCASE "       cell+       endof
!         ['] _then       of -tab d_cr ." THEN    "       cell+       endof
!         ['] _begin      of      d_cr ." BEGIN   " +tab  cell+       endof
!         ['] _while      of -tab d_cr ." WHILE   " +tab  cell+ cell+ endof
!         ['] _until      of -tab d_cr ." UNTIL   "       cell+ cell+ endof
!         ['] _repeat     of -tab d_cr ." REPEAT  "       cell+ cell+ endof
!         ['] _again      of -tab d_cr ." AGAIN   "       cell+ cell+ endof
!         ['] compile     of .word .word                              endof
!         ['] unnest      of ." ; "  drop  0                          endof
!         ['] unnestm     of ." ;M " drop  0                          endof
!         ['] unnestp     of ." ;  " drop  0                          endof
!         ['] (;code)     of -tab d_cr .(;CODE) tab +tab              endof
!         ['] create      of d_cr .word tab +tab                      endof
!         ['] init-locals of               .locals                    endof
                             false .execution-class-chain do-chain 0=
                             if    swap .word swap
--- 142,192 ----
                  then    ;
  
+ 0 value hi-branch
+ 
+ : branch+ ( ip -- ip' )  \ advance ip by 1 cell and update hi-branch if necessary
+         cell+ dup @ hi-branch umax to hi-branch ;
+ 
+ : .end ( ip -- ip'|0 ) \ advance ip by 1 cell, return false if there are no branches
+                        \ past this address
+         cell+ dup hi-branch u< 0= if ." ;"  drop  0
+                                 else ." EXIT"  then ; 
+ 
  : .execution-class  ( ip cfa -- ip' )
      case
!         ['] lit         of cell+ ." lit "   .word                     endof
!         ['] (&of-local) of cell+ ." &OF "   .word                     endof
!         ['] (&of-VALUE) of cell+ ." &OF "   .word                     endof
!             &flit       of cell+ ." flit "  .float                    endof
!         ['] (is)        of cell+ ." (is) "  .word                     endof
!         ['] (.")        of ." ."        .string                       endof
!         ['] (S")        of ." S"        .string                       endof
!         ['] (Z")        of ." Z"        .string                       endof
!         ['] (C")        of ." C"        .string                       endof
!         ['] (abort")    of ." ABORT"    .string                       endof
!         ['] ?branch     of      d_cr ." IF      " +tab  branch+ cell+ endof
!         ['] -?branch    of      d_cr ." -IF     " +tab  branch+ cell+ endof        
!         ['] branch      of -tab d_cr ." ELSE    " +tab  branch+ cell+ endof
!         ['] (do)        of      d_cr ." DO      " +tab  branch+ cell+ endof
!         ['] (?do)       of      d_cr ." ?DO     " +tab  branch+ cell+ endof
!         ['] (loop)      of -tab d_cr ." LOOP    "       cell+   cell+ endof
!         ['] (+loop)     of -tab d_cr ." +LOOP   "       cell+   cell+ endof
!         ['] _case       of      d_cr ." CASE    " +tab  cell+         endof
!         ['] _of         of      d_cr ." OF      " +tab  branch+ cell+ endof
          ['] _endof      of  tab      ." ENDOF   " -tab  d_cr
!                                                         branch+ cell+ endof
!         ['] _endcase    of -tab d_cr ." ENDCASE "       cell+         endof
!         ['] _then       of -tab d_cr ." THEN    "       cell+         endof
!         ['] _begin      of      d_cr ." BEGIN   " +tab  cell+         endof
!         ['] _while      of -tab d_cr ." WHILE   " +tab  branch+ cell+ endof
!         ['] _until      of -tab d_cr ." UNTIL   "       cell+   cell+ endof
!         ['] _repeat     of -tab d_cr ." REPEAT  "       cell+   cell+ endof
!         ['] _again      of -tab d_cr ." AGAIN   "       cell+   cell+ endof
!         ['] compile     of .word .word                                endof
!         ['] unnest      of .end space                                 endof
!         ['] unnestp     of .end space                                 endof
!         ['] unnestm     of .end ." M "                                endof
!         ['] (;code)     of -tab d_cr .(;CODE) tab +tab                endof
!         ['] create      of d_cr .word tab +tab                        endof
!         ['] init-locals of               .locals                      endof
                             false .execution-class-chain do-chain 0=
                             if    swap .word swap
***************
*** 188,191 ****
--- 198,202 ----
  
  : .PFA          ( cfa -- )
+                 0 to hi-branch
                  tabing-on
                  0TAB +TAB tab
***************
*** 230,235 ****
                  ." : "  dup .name 2 spaces  >body .pfa   ;
  
- 
- \ Display category of word                            24APR84HHL
  : .DEFER        ( cfa -- )
                  ." DEFER " DUP .NAME   ." IS "  >BODY @ (SEE)  ;
--- 241,244 ----

[Win32forth-cvs] win32forth/apps/Solipon2 051.SOL,NONE,1.1 052.SOL,NONE,1.1 053.SOL,NONE,1.1 054.SOL,NONE,1.1 055.SOL,NONE,1.1 056.SOL,NONE,1.1 057.SOL,NONE,1.1 058.SOL,NONE,1.1 059.SOL,NONE,1.1 060.SOL,NONE,1.1 061.SOL,NONE,1.1 062.SOL,NONE,1.1 063.SOL,NONE,1.1 064.SOL,NONE,1.1 065.SOL,NONE,1.1 066.SOL,NONE,1.1 067.SOL,NONE,1.1 068.SOL,NONE,1.1 069.SOL,NONE,1.1 070.SOL,NONE,1.1 071.SOL,NONE,1.1 072.SOL,NONE,1.1 073.SOL,NONE,1.1 074.SOL,NONE,1.1 081.SOL,NONE,1.1 083.SOL,NONE,1.1 107.SOL,NONE,1.1 Applause7.wav,NONE,1.1 Av7.wav,NONE,1.1 BLEEP7.wav,NONE,1.1 L101.SOL,NONE,1.1 L121.SOL,NONE,1.1 L164.SOL,NONE,1.1 L49.SOL,NONE,1.1 L97.SOL,NONE,1.1 SOLIDIAL.F,NONE,1.1 SOLIPION.F,NONE,1.1 Solipion.bmp,NONE,1.1 YAHOO.WAV,NONE,1.1 ep7.wav,NONE,1.1 readme.txt,NONE,1.1 solipion.dat,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Solipon2
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv732/win32forth/apps/Solipon2

Added Files:
	051.SOL 052.SOL 053.SOL 054.SOL 055.SOL 056.SOL 057.SOL 
	058.SOL 059.SOL 060.SOL 061.SOL 062.SOL 063.SOL 064.SOL 
	065.SOL 066.SOL 067.SOL 068.SOL 069.SOL 070.SOL 071.SOL 
	072.SOL 073.SOL 074.SOL 081.SOL 083.SOL 107.SOL Applause7.wav 
	Av7.wav BLEEP7.wav L101.SOL L121.SOL L164.SOL L49.SOL L97.SOL 
	SOLIDIAL.F SOLIPION.F Solipion.bmp YAHOO.WAV ep7.wav 
	readme.txt solipion.dat 
Log Message:
Jos: Solipon2 written by Bruno Gauthier

--- NEW FILE: 051.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 054.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 067.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: Solipion.bmp ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 062.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: Applause7.wav ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: L49.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: Av7.wav ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 069.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 107.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 074.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 053.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 083.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 059.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 070.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: BLEEP7.wav ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 068.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: L121.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 057.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: readme.txt ---
\ bruno GAUTHIER
\ vendredi, avril 01 2005 - 16:11
\ SOLIPION 2.0
\ Classic Morpion Solitaire Like Game
\ We place the 5 th pawn on a line in any directions like xxxx0 OR x0xxx etc
\ Then a line is drawn.
\ The program controls if we can place a Pawn (or dot) here or there.
\ If for a particulare place they are severals lines that could be drawns then
\ the prog shows each, one after one, with yellow color in a loop.
\ So to choose one of them, just click and the program will  draw this one.
\ If we want to undo, just click on the "to last move" button in the toobar.
\ 
\ The goal is to draw a maximum of lines.
\ The principe of the game is simple but that is not so easy to beat 100 lines.
\ The actual best published record is 170 lines !! Amazing :)
\ 
\ They are a zoom in the toolbar to adjust the board as we want :)
\ Solipion, needs to be seriouly factorized,simplified and debuggued.
\ Solipion seems to cheat with the scores :)
\ In fact if Solipion found a move to play after my, our last move, then he place it,
\ then his name also in the score (if of course that is a good score) 
\
\ I go back to play now :)
\ 


To add a Pawn to draw a line, 4 Pawns in the same direction must already exist.
We can use only one pawn of an already line drawn.
Solipion, controls if we follow the rules.
Any directions are possible, vertical, horizontal,diagonally.

links : http://croix2malte.free.fr/indexGB.php
http://euler.free.fr/morpion.htm

New in version 2.01:
Labels on left and up of the board. 
Visible only if the board is pushed right and down 
with the keys : shift +down  shift +right.

Added also : shift +left and shift +up.
--- NEW FILE: 073.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 058.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 065.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 066.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: YAHOO.WAV ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: L164.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 063.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 064.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: L97.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: L101.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: ep7.wav ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 072.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 052.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 055.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: SOLIDIAL.F ---
\ solidial.f

        0 value rank-in-dial
        0 value dial-busy?


:OBJECT SoliPion-Dial <Super DialogWindow

        EditControl Edit_1            \ an edit window
        StaticControl Title
        StaticControl HeadRank
        StaticControl HeadText
        StaticControl HeadScore
        StaticControl Text_1
        StaticControl Text_2
        StaticControl Text_3
        StaticControl Text_4
        StaticControl Text_5
        StaticControl Text_6
        StaticControl Text_7
        StaticControl Text_8
        StaticControl Text_9
        StaticControl Text_10
        StaticControl Rank1
        StaticControl Rank2
        StaticControl Rank3
        StaticControl Rank4
        StaticControl Rank5
        StaticControl Rank6
        StaticControl Rank7
        StaticControl Rank8
        StaticControl Rank9
        StaticControl Rank10
        StaticControl Score1
        StaticControl Score2
        StaticControl Score3
        StaticControl Score4
        StaticControl Score5
        StaticControl Score6
        StaticControl Score7
        StaticControl Score8
        StaticControl Score9
        StaticControl Score10
        ButtonControl Button_1   \ a button


: CloseSample   ( -- )
        Close: [ self ]
        ;

:M ExWindowStyle: ( -- style )
        ExWindowStyle: SUPER

        ;M

:M WindowStyle: ( -- style )
        WindowStyle: SUPER
        WS_OVERLAPPED OR
        ;M

:M WindowTitle: ( -- title )
        z" Solipion"


        ;M

:M StartSize:   ( -- width height )
        350 305 ;M

:M StartPos:    ( -- x y )
        CW_USEDEFAULT CW_USEDEFAULT ;M


:M On_Init:     (   -- )
        On_Init: super

        time-reset

        self                               Start: title
                                        GetStyle: title
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR

                                        SetStyle: title
                        4  4 290 25         Move: title
               s" Table of Bests Scores" SetText: title

                        self               Start: HeadRank
                                        GetStyle: HeadRank
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                        SetStyle: HeadRank
                        4 30  60 25         Move: HeadRank

                                s" Rank" SetText: HeadRank

                        self               Start: HeadText
                                        GetStyle: HeadText
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                        SetStyle: HeadText
                       72 30 150 25         Move: HeadText
                               S" Name"  SetText: HeadText

                        self               Start: HeadScore
                                        GetStyle: HeadScore
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                        SetStyle: HeadScore
                       230 30 64 25         Move: HeadScore
                              S" Score"  SetText: HeadScore


       11 1 DO

         Rank-in-dial i =

               if


                       self                 Start: Edit_1

                                         GetStyle: Edit_1
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                         SetStyle: Edit_1

                      72 30 25 i * + 150 25  Move: Edit_1


                       self              SetFocus: Edit_1


               else
               i case
                 1 of
                                                self   Start: Text_1
                                                    GetStyle: Text_1
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_1

                               72 30 25 i * + 150 25    Move: Text_1
                          bests-table i 1- 22 * + 20 SetText: Text_1
                   endof
                 2 of
                                                self   Start: Text_2
                                                    GetStyle: Text_2
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_2

                               72 30 25 i * + 150 25    Move: Text_2
                        bests-table i 1- 22 * + 20 SetText: Text_2
                   endof

                 3 of                           self   Start: Text_3
                                                    GetStyle: Text_3
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_3

                               72 30 25 i * + 150 25    Move: Text_3
                        bests-table i 1- 22 * + 20 SetText: Text_3
                   endof
                 4 of                           self   Start: Text_4
                                                    GetStyle: Text_4
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_4

                               72 30 25 i * + 150 25    Move: Text_4
                        bests-table i 1- 22 * + 20 SetText: Text_4
                   endof

                 5 of                           self   Start: Text_5
                                                    GetStyle: Text_5
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_5

                               72 30 25 i * + 150 25    Move: Text_5
                        bests-table i 1- 22 * + 20 SetText: Text_5
                   endof
                 6 of                           self   Start: Text_6
                                                    GetStyle: Text_6
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_6

                               72 30 25 i * + 150 25    Move: Text_6
                        bests-table i 1- 22 * + 20 SetText: Text_6
                   endof

                 7 of                           self   Start: Text_7
                                                    GetStyle: Text_7
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_7

                               72 30 25 i * + 150 25    Move: Text_7
                        bests-table i 1- 22 * + 20 SetText: Text_7
                   endof
                 8 of                           self   Start: Text_8
                                                    GetStyle: Text_8
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_8

                               72 30 25 i * + 150 25    Move: Text_8
                        bests-table i 1- 22 * + 20 SetText: Text_8
                   endof


                 9 of                           self   Start: Text_9
                                                    GetStyle: Text_9
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_9

                               72 30 25 i * + 150 25    Move: Text_9
                        bests-table i 1- 22 * + 20 SetText: Text_9
                   endof
                10 of                           self   Start: Text_10
                                                    GetStyle: Text_10
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                    SetStyle: Text_10

                               72 30 25 i * + 150 25    Move: Text_10
                        bests-table i 1- 22 * + 20 SetText: Text_10
                   endof
                endcase

              then

              i
              case
              1 of                              self Start: Rank1
                                                  GetStyle: Rank1
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank1

                               4 30 25 i * + 60 25    Move: Rank1
                                  s" 1"  SetText: Rank1
                endof
              2 of                              self Start: Rank2
                                                  GetStyle: Rank2
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank2

                               4 30 25 i * + 60 25    Move: Rank2
                                            s" 2"  SetText: Rank2
                endof
              3 of                              self Start: Rank3
                                                  GetStyle: Rank3
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank3

                               4 30 25 i * + 60 25    Move: Rank3
                                            s" 3"  SetText: Rank3
                endof
              4 of                              self Start: Rank4
                                                  GetStyle: Rank4
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank4

                               4 30 25 i * + 60 25    Move: Rank4
                                            s" 4"  SetText: Rank4
                endof
              5 of                              self Start: Rank5
                                                  GetStyle: Rank5
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank5

                               4 30 25 i * + 60 25    Move: Rank5
                                            s" 5"  SetText: Rank5
                endof
              6 of                              self Start: Rank6
                                                  GetStyle: Rank6
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank6

                               4 30 25 i * + 60 25    Move: Rank6
                                            s" 6"  SetText: Rank6
                endof

              7 of                              self Start: Rank7
                                                  GetStyle: Rank7
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank7

                               4 30 25 i * + 60 25    Move: Rank7
                                            s" 7"  SetText: Rank7
                endof
              8 of                              self Start: Rank8
                                                  GetStyle: Rank8
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank8

                               4 30 25 i * + 60 25    Move: Rank8
                                            s" 8"  SetText: Rank8
                endof
              9 of                              self Start: Rank9
                                                  GetStyle: Rank9
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank9

                               4 30 25 i * + 60 25    Move: Rank9
                                            s" 9"  SetText: Rank9
                endof
             10  of                             self Start: Rank10
                                                  GetStyle: Rank10
                        WS_GROUP     OR
                        SS_CENTER    OR
                        WS_BORDER    OR
                                                  SetStyle: Rank10

                               4 30 25 i * + 60 25    Move: Rank10
                                           s" 10"  SetText: Rank10
                endof

              endcase

 i
 case
        1 of                                               self Start: Score1
                                                             GetStyle: Score1
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score1
                                        230 30 25 i * + 64 25    Move: Score1
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score1
        endof
        2 of                                               self Start: Score2
                                                             GetStyle: Score2
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score2
                                        230 30 25 i * + 64 25    Move: Score2
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score2
        endof
        3 of                                               self Start: Score3
                                                             GetStyle: Score3
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score3

                                        230 30 25 i * + 64 25    Move: Score3
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score3
        endof
        4 of                                               self Start: Score4
                                                             GetStyle: Score4
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score4
                                        230 30 25 i * + 64 25    Move: Score4
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score4
        endof
        5 of                                               self Start: Score5
                                                             GetStyle: Score5
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score5
                                        230 30 25 i * + 64 25    Move: Score5
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score5
        endof
        6 of                                               self Start: Score6
                                                             GetStyle: Score6
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score6
                                        230 30 25 i * + 64 25    Move: Score6
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score6
        endof
        7 of                                               self Start: Score7
                                                             GetStyle: Score7
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score7
                                        230 30 25 i * + 64 25    Move: Score7
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score7
        endof
        8 of                                               self Start: Score8
                                                             GetStyle: Score8
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score8
                                        230 30 25 i * + 64 25    Move: Score8
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score8
        endof                                              self Start: Score9
        9 of
                                                             GetStyle: Score9
                       WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score9
                                        230 30 25 i * + 64 25    Move: Score9
                bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score9
        endof
        10 of                                             self Start: Score10
                                                            GetStyle: Score10
                      WS_GROUP OR SS_CENTER OR WS_BORDER OR SetStyle: Score10
                                      230 30 25 i * + 64 25     Move: Score10
               bests-table i 1- 22 * + 20 + w@ 0 <# # # # #> SetText: Score10
        endof

        endcase


            LOOP


                IDOK               SetID: Button_1
                self               Start: Button_1
                                GetStyle: Button_1
                BS_DEFPUSHBUTTON OR
                WS_GROUP         OR
                                SetStyle: Button_1

                300 30 36 275       Move: Button_1
                s" OK"           SetText: Button_1




           ;M

:M On_Paint:    ( -- )          \ screen redraw procedure
        \ 0 0 screen-size LTGRAY  FillArea: dc
        0 0 screen-size LTBLUE  FillArea: dc


                ;M

:M Close:       ( -- )
        Rank-in-dial true =
        if      FALSE to dial-busy?
        else
                bests-table Rank-in-dial 1- 22 * + 20 blank

                GetText: Edit_1 drop bests-table Rank-in-dial 1- 22 * + 20 cmove

                FALSE to dial-busy?
        then
        Close: SUPER
;M

:M WM_COMMAND  ( hwnd msg wparam lparam -- res )
        over LOWORD ( ID )

        case
                IDOK    of Close: self  endof
        endcase
0 ;M

;OBJECT






--- NEW FILE: solipion.dat ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 056.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 071.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 061.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 081.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: 060.SOL ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: SOLIPION.F ---
\ SOLIPION.F     2.01

fload old\optimize.f

        only forth also definitions

        1280    value screen-mwidth
        1024    value screen-mheight
         300    to screen-width
         300    to screen-height
           0    value smallstring
           0    value stamper
           0    value string-player-name
           0    value nRaw
           0    value nLine
           0    value univers
           0    value univers1
           0    value univers2
           0    value univers3
[...1775 lines suppressed...]
                                              'E' +k_control pushkey
                                              'R' +k_control pushkey       endof

                k_right     +k_shift    of     8 +to dx
                                               'E' +k_control pushkey
                                               'R' +k_control pushkey      endof
                k_up        +k_shift    of    -8 +to dy
                                              'E' +k_control pushkey
                                              'R' +k_control pushkey       endof
                k_down      +k_shift    of     8 +to dy
                                              'E' +k_control pushkey
                                              'R' +k_control pushkey       endof
                endcase

        AGAIN
        ;

' solipion turnkey solipion       \ build an application on disk
5 pause-seconds

[Win32forth-cvs] win32forth/apps/Solipon2 - New directory

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Solipon2
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24749/Solipon2

Log Message:
Directory /cvsroot/win32forth/win32forth/apps/Solipon2 added to the repository

[Win32forth-cvs] win32forth fkernel.exe,1.12,1.13

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23246

Modified Files:
	fkernel.exe 
Log Message:
arm: rename word str(nc)= to istr= (case insensitive compare)
add id headers to assembler files
modifications to disassembler to allow reassembley from generated text
move LDP inline to system area
correct comment in meta compiler

Index: fkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth/fkernel.exe,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
Binary files /tmp/cvsnmcefJ and /tmp/cvsKR7UdK differ

[Win32forth-cvs] win32forth/apps/SciEdit AnsLink.f,1.1,1.2 ClassBrowser.f,1.2,1.3

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/SciEdit
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23246/apps/SciEdit

Modified Files:
	AnsLink.f ClassBrowser.f 
Log Message:
arm: rename word str(nc)= to istr= (case insensitive compare)
add id headers to assembler files
modifications to disassembler to allow reassembley from generated text
move LDP inline to system area
correct comment in meta compiler

Index: AnsLink.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/SciEdit/AnsLink.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** AnsLink.f	21 Dec 2004 00:18:47 -0000	1.1
--- AnsLink.f	2 Jun 2005 21:14:54 -0000	1.2
***************
*** 394,398 ****
  		if   ANS-WORDS >r
  		     begin  2dup r@ count dup
! 		     while  STR(NC)= 0<>
  			    if 2drop r> exit then
  			    r> skip-string skip-string skip-string >r
--- 394,398 ----
  		if   ANS-WORDS >r
  		     begin  2dup r@ count dup
! 		     while  ISTR= 0<>
  			    if 2drop r> exit then
  			    r> skip-string skip-string skip-string >r
***************
*** 417,419 ****
  
  module
- 

[Win32forth-cvs] win32forth/src 486ASM.F,1.2,1.3 ASMWIN32.F,1.3,1.4 DIS486.F,1.2,1.3 EXCEPTIO.F,1.4,1.5 Shell.f,1.1,1.2 paths.f,1.3,1.4

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23246/src

Modified Files:
	486ASM.F ASMWIN32.F DIS486.F EXCEPTIO.F Shell.f paths.f 
Log Message:
arm: rename word str(nc)= to istr= (case insensitive compare)
add id headers to assembler files
modifications to disassembler to allow reassembley from generated text
move LDP inline to system area
correct comment in meta compiler

Index: DIS486.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/DIS486.F,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** DIS486.F	3 May 2005 08:47:34 -0000	1.2
--- DIS486.F	2 Jun 2005 21:14:55 -0000	1.3
***************
*** 1,2 ****
--- 1,4 ----
+ \ $Id$
+ 
  \ 80386 Disassembler
  
***************
*** 20,24 ****
  DECIMAL
  
! 32 constant comment-col
[...979 lines suppressed...]
                          start/stop
                  repeat  drop .s" END-CODE  "
!                 ;
  
  hidden
***************
*** 1523,1527 ****
  
  : seemore       ( -- )
-                 tabing-on 0tab
                  next-inst
                  cr inst
--- 1435,1438 ----
***************
*** 1530,1532 ****
  ONLY FORTH ALSO DEFINITIONS
  
- 

[Win32forth-cvs] win32forth/src/kernel fkernel.f,1.13,1.14 meta-fkernel.f,1.1,1.2

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth/src/kernel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23246/src/kernel

Modified Files:
	fkernel.f meta-fkernel.f 
Log Message:
arm: rename word str(nc)= to istr= (case insensitive compare)
add id headers to assembler files
modifications to disassembler to allow reassembley from generated text
move LDP inline to system area
correct comment in meta compiler

Index: fkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/kernel/fkernel.f,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** fkernel.f	3 May 2005 13:19:49 -0000	1.13
--- fkernel.f	2 Jun 2005 21:14:55 -0000	1.14
***************
*** 1419,1423 ****
                  next    c;
  
! CODE STR(NC)=   ( adr1 len1 adr2 len2 -- flag ) \ compares two strings, case insensitive
                  mov     -4 [ebp], esi           \ save esi
                  pop     edi                     \ edi=adr2
--- 1419,1423 ----
                  next    c;
  
! CODE ISTR=      ( adr1 len1 adr2 len2 -- flag ) \ compares two strings, case insensitive
                  mov     -4 [ebp], esi           \ save esi
                  pop     edi                     \ edi=adr2
***************
*** 5010,5014 ****
                      ' LOCAL10 , ' LOCAL11 ,
  
! | CREATE LDP  0 , 0 , 0 , DP-LINK LINK, ," LOCALS"  \ locals pointer
  
  in-system
--- 5010,5014 ----
                      ' LOCAL10 , ' LOCAL11 ,
  
! | CREATE LDP  0 , 0 , 0 , DP-LINK LINK, ," *LOCALS"  \ locals pointer
  
  in-system
***************
*** 5391,5395 ****
                  tiblen    +     (source) cell+ !
                  sys-size if                            \ when not turnkeyed
!                   locals-len malloc to LOCALS-AREA \ allocate buffers
                    LOCALS-VOCINIT                   \ initialise
                  then
--- 5391,5395 ----
                  tiblen    +     (source) cell+ !
                  sys-size if                            \ when not turnkeyed
!                   sys-here locals-len sys-allot to LOCALS-AREA \ allocate buffers
                    LOCALS-VOCINIT                   \ initialise
                  then
***************
*** 5732,5734 ****
  ' ?THROW        RESOLVES ?THROW
  ' WARNMSG       RESOLVES WARNMSG
- 

[Win32forth-cvs] win32forth/apps/ForthForm FORMOBJECT.F,1.2,1.3

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/ForthForm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23246/apps/ForthForm

Modified Files:
	FORMOBJECT.F 
Log Message:
arm: rename word str(nc)= to istr= (case insensitive compare)
add id headers to assembler files
modifications to disassembler to allow reassembley from generated text
move LDP inline to system area
correct comment in meta compiler

Index: FORMOBJECT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORMOBJECT.F,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** FORMOBJECT.F	5 May 2005 09:43:26 -0000	1.2
--- FORMOBJECT.F	2 Jun 2005 21:14:54 -0000	1.3
***************
*** 1011,1015 ****
  
  : IsNewForm?    ( -- f )  \ has form not yet been saved?
!                 formname count s" untitled.ff" str(nc)= ;
  
  : SaveIt?       { \ temp$ -- f }
--- 1011,1015 ----
  
  : IsNewForm?    ( -- f )  \ has form not yet been saved?
!                 formname count s" untitled.ff" ISTR= ;
  
  : SaveIt?       { \ temp$ -- f }
***************
*** 1794,1796 ****
  
  ;Class
! \s

[Win32forth-cvs] win32forth-610old/src SEE.F,1.1,1.2

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-610old/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13857/win32forth-610old/src

Modified Files:
	SEE.F 
Log Message:
gah: altered .LOCALS and (.LOCALS) to print in reverse order (i.e. correctly)

Index: SEE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-610old/src/SEE.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** SEE.F	14 Dec 2004 23:53:57 -0000	1.1
--- SEE.F	1 Jun 2005 09:56:57 -0000	1.2
***************
*** 114,119 ****
                  .word .word ;
                  
! : (.LOCALS)     ( n m -- )
!                 ?do i ." LOCAL" 1 .r space loop ;
  
  : .LOCALS       ( IP -- IP' )
--- 114,119 ----
                  .word .word ;
                  
! : (.LOCALS)     ( t-1 n -- )
!                 0 ?do dup i - ." LOCAL" 1 .r space loop drop ;
  
  : .LOCALS       ( IP -- IP' )
***************
*** 121,128 ****
                  dup 2 + sw@ negate               \ init locals   ( IP init )
                  over sw@ negate                  \ uninit locals ( IP init uninit )
!                 over 0 (.locals)                 \ init locals   ( IP init uninit init 0 ... do )
!                 -if ." | "                       \ if any unit locals ( IP init uninit )
!                   bounds (.locals)
!                 else 2drop
                  then ." } "
                  CELL+ ;
--- 121,129 ----
                  dup 2 + sw@ negate               \ init locals   ( IP init )
                  over sw@ negate                  \ uninit locals ( IP init uninit )
!                 2dup + 1-
!                 rot (.locals)                    \ init locals   ( IP uninit total-1 init 0 ... do )
!                 -if ." | "                       \ if any unit locals ( IP uninit )
!                 dup 1- swap (.locals)
!                 else drop
                  then ." } "
                  CELL+ ;
***************
*** 296,297 ****
--- 297,299 ----
  MODULE          \ end of the module
  
+ 

[Win32forth-cvs] win32forth/src SEE.F,1.1,1.2

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12679/win32forth/src

Modified Files:
	SEE.F 
Log Message:
gah: altered .LOCALS and (.LOCALS) to print in reverse order (i.e. correctly)

Index: SEE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/SEE.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** SEE.F	21 Dec 2004 00:19:08 -0000	1.1
--- SEE.F	1 Jun 2005 09:55:12 -0000	1.2
***************
*** 114,119 ****
                  .word .word ;
                  
! : (.LOCALS)     ( n m -- )
!                 ?do i ." LOCAL" 1 .r space loop ;
  
  : .LOCALS       ( IP -- IP' )
--- 114,119 ----
                  .word .word ;
                  
! : (.LOCALS)     ( t-1 n -- )
!                 0 ?do dup i - ." LOCAL" 1 .r space loop drop ;
  
  : .LOCALS       ( IP -- IP' )
***************
*** 121,128 ****
                  dup 2 + sw@ negate               \ init locals   ( IP init )
                  over sw@ negate                  \ uninit locals ( IP init uninit )
!                 over 0 (.locals)                 \ init locals   ( IP init uninit init 0 ... do )
!                 -if ." | "                       \ if any unit locals ( IP init uninit )
!                   bounds (.locals)
!                 else 2drop
                  then ." } "
                  CELL+ ;
--- 121,129 ----
                  dup 2 + sw@ negate               \ init locals   ( IP init )
                  over sw@ negate                  \ uninit locals ( IP init uninit )
!                 2dup + 1-
!                 rot (.locals)                    \ init locals   ( IP uninit total-1 init 0 ... do )
!                 -if ." | "                       \ if any unit locals ( IP uninit )
!                 dup 1- swap (.locals)
!                 else drop
                  then ." } "
                  CELL+ ;
***************
*** 296,297 ****
--- 297,299 ----
  MODULE          \ end of the module
  
+ 

[Win32forth-cvs] win32forth/apps/Chess TOOLSET.F,1.4,1.5

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Chess
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17048/win32forth/apps/Chess

Modified Files:
	TOOLSET.F 
Log Message:
Jos: Added: context>current and all-warnings-off

Index: TOOLSET.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Chess/TOOLSET.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** TOOLSET.F	14 May 2005 11:40:20 -0000	1.4
--- TOOLSET.F	29 May 2005 23:26:32 -0000	1.5
***************
*** 1,3 ****
! (( May 27th, 2004   by J.v.d.Ven.  ( http://home.planet.nl/~josv )
   Needed compiler Win32forth version 4.2 build 0671.
   Objective: extend Win32forth with my old fashion tools from
--- 1,3 ----
! (( May 30th, 2005   by J.v.d.Ven.  ( http://home.planet.nl/~josv )
   Needed compiler Win32forth version 4.2 build 0671.
   Objective: extend Win32forth with my old fashion tools from
***************
*** 7,25 ****
              Perhaps you will hate it. That's ok
  
! Modifications: in this version:
! 
! \ Solved a bug in set-priority
  
! \ Additions are made at the end.
! ))
  
! Forth
  
  s" Win32Forth" environment? not [if]  cr
  .( Needs Win32Forth version 4.2 build 0671 or better.) abort  [then]  drop
  
! INTERNAL WinLibrary WINMM.DLL EXTERNAL
  
! only forth definitions decimal
  
  anew toolset.f
--- 7,23 ----
              Perhaps you will hate it. That's ok
  
! Note: Needs Win32Forth 6.11.xx version.
  
! Modifications: in this version:
! Added: context>current and all-warnings-off
  
! \ Additions are made at the end. ))
  
  s" Win32Forth" environment? not [if]  cr
  .( Needs Win32Forth version 4.2 build 0671 or better.) abort  [then]  drop
  
! INTERNAL WinLibrary WINMM.DLL EXTERNAL PREVIOUS
  
! decimal
  
  anew toolset.f
***************
*** 31,38 ****
  27 constant escape              34 constant quote
  
  synonym read         r/o        synonym write   r/w
  synonym erase-screen cls        synonym ?ms     ms@
  synonym d            dir        synonym >>>     noop
! synonym PRIVATES     noop       synonym PRIVATE noop
  \ synonym Private:   noop       synonym Public: noop
  synonym DEPRIVE      noop       synonym ;P      ;
--- 29,41 ----
  27 constant escape              34 constant quote
  
+ : all-warnings-off ( -- )  dpr-warning-off  sys-warning-off warning off ;
+ : all-warnings-on  ( -- )  dpr-warning-on  sys-warning-on warning on    ;
+ 
+ all-warnings-off
+ 
  synonym read         r/o        synonym write   r/w
  synonym erase-screen cls        synonym ?ms     ms@
  synonym d            dir        synonym >>>     noop
! synonym PRIVATES     noop
  \ synonym Private:   noop       synonym Public: noop
  synonym DEPRIVE      noop       synonym ;P      ;
***************
*** 42,47 ****
--- 45,58 ----
  synonym -s           r>drop     synonym lo      bye
  
+ defined  &local nip not [IF]
+ synonym &local       &of
+ [THEN]
+ 
  ' \ alias **
  
+ in-system
+ 
+ in-application
+ 
  : reversed      ( - )            16777215 1 fgbg! ;
  : normal        ( - )            1 -1 fgbg! ;
***************
*** 50,54 ****
  : bin           ( - )            2 base !  ;
  : missing       ( - )            abort" missing"  ;
! : tp            ( - )            .s key escape =  if abort  then cr ;
  : ftp           ( - )            f.s key escape =  if abort  then cr ;
  : always        ( flag - true )  drop true  ;
--- 61,65 ----
  : bin           ( - )            2 base !  ;
  : missing       ( - )            abort" missing"  ;
! : tp            ( - )            .s key escape  =  if abort  then cr ;
  : ftp           ( - )            f.s key escape =  if abort  then cr ;
  : always        ( flag - true )  drop true  ;
***************
*** 91,96 ****
        MB_OK MB_ICONSTOP  or
        MB_TASKMODAL or
!       z" Error:"
!       message$ 1+
        NULL call MessageBox drop
   ;
--- 102,107 ----
        MB_OK MB_ICONSTOP  or
        MB_TASKMODAL or
!       z" Error:" 
!       message$ 1+ 
        NULL call MessageBox drop
   ;
***************
*** 135,139 ****
  : (ABORT")      ( f -- )
                  \ _.rstack
!                 2r@  at-word ! drop ((")) SWAP
                  IF      MSG !
                          THROW_ABORTQ THROW
--- 146,150 ----
  : (ABORT")      ( f -- )
                  \ _.rstack
!                 2r@  abs>rel at-word ! drop ((")) SWAP
                  IF      MSG !
                          THROW_ABORTQ THROW
***************
*** 147,152 ****
  
  : test2 test ;
!  test2 \
! ))
  
  : here!         ( n - )         here ! ;
--- 158,162 ----
  
  : test2 test ;
!  test2 \ ))
  
  : here!         ( n - )         here ! ;
***************
*** 178,182 ****
     drop
   ;
! \ 1234 here ! here 10 cadump abort
  
  
--- 188,192 ----
     drop
   ;
! \ 1234 here ! here  10 cadump abort
  
  
***************
*** 187,191 ****
  
  synonym local  to   \ NOTE define the local as value before using local
- synonym fsqr   fsqrt
  synonym pi     fpi
  
--- 197,200 ----
***************
*** 507,511 ****
      time-buf 2 + w! \ month
      time-buf 6 + w! \ day
!     hld-max hld 0  time-buf
      r> LOCALE_SYSTEM_DEFAULT
      call GetDateFormat dup 0= abort" ldate failed" hld-count
--- 516,520 ----
      time-buf 2 + w! \ month
      time-buf 6 + w! \ day
!     hld-max hld  0  time-buf 
      r> LOCALE_SYSTEM_DEFAULT
      call GetDateFormat dup 0= abort" ldate failed" hld-count
***************
*** 517,521 ****
  
  : ltime         ( time-buf - adr count )    \ time-buf must be filled
!     hld-max hld 0  time-buf
      TIME_FORCE24HOURFORMAT  LOCALE_SYSTEM_DEFAULT
      call GetTimeFormat dup 0= abort" ltime failed" hld-count
--- 526,530 ----
  
  : ltime         ( time-buf - adr count )    \ time-buf must be filled
!     hld-max hld  0  time-buf 
      TIME_FORCE24HOURFORMAT  LOCALE_SYSTEM_DEFAULT
      call GetTimeFormat dup 0= abort" ltime failed" hld-count
***************
*** 656,705 ****
  : empty_key_buf ( - )                       key? if key drop then  ;
  
- : fchoose     100000 * random s>f 100000e f/ ;        \ <n> --- <> F: <> --- <r>
  
- \ : fvalue-to-string \ ( adr - ) fs: ( n - ) \ Borrowed from f.
- \          >r 0 r@ c!                        \ Now it puts a float in a string
- \                 fdepth 0 <=
- \                 IF      ." Empty " r> drop EXIT
- \                 THEN
- \                 precision 1 max set-precision
- \                 fexam 0x0200 and
- \                 IF      fabs  s" -" r@ +place
- \                 THEN
- \                 fdup f0.5 f<
- \                 IF      s" ." r@  +place f1.0 f+ $ftemp
- \                         precision 1+ maxsig umin
- \                         represent
- \                         drop drop drop
- \                         $ftemp 1+ precision maxsig 1- umin
- \                         r@ +place s" " r@ +place
- \                 ELSE    $ftemp precision represent 0=
- \                         IF      drop drop $ftemp precision
- \                                 r@ +place s" " r@ +place
- \                         ELSE    drop dup precision <
- \                                 IF      dup 0=
- \                                         IF      drop s" ." r@ +place
- \                                                 $ftemp precision
- \                                                 r@ +place s" " r> +place EXIT
- \                                         THEN
- \                                         $ftemp over r@ +place s" ." r@ +place
- \                                         $ftemp over + swap precision
- \                                         swap - r@ +place s" " r@ +place
- \                                 ELSE    dup precision =
- \                                         IF      $ftemp swap r@ +place
- \                                                 s" . " r> +place
- \                                                 EXIT
- \                                         THEN
- \                                         $ftemp precision r@ +place r@ pad !
- \                                         precision - 0
- \                                         DO       s" 0" pad @ +place
- \                                         LOOP
- \                                          s" . " r@ +place
- \                                 THEN
- \                         THEN
- \                 THEN r> drop ;
  
! ' (f.) alias fvalue-to-string
!  
  : string>float     \ ( adr - f )  FS: ( - n ) \ Note: 0 on FS when f is false
     count >float dup not
--- 665,675 ----
  : empty_key_buf ( - )                       key? if key drop then  ;
  
  
  
! \ : fchoose     100000 * random s>f 100000e f/ ;        ( <n> --- <> F: <> --- <r> )
! \ 2024 .s abort
! 
! synonym fvalue-to-string    (F.)
! 
  : string>float     \ ( adr - f )  FS: ( - n ) \ Note: 0 on FS when f is false
     count >float dup not
***************
*** 716,719 ****
--- 686,690 ----
   ;
  
+ 
  \ 1.5e2 fvalue aa
  \ 10 string: Aa$  Aa$ string" foo"
***************
*** 793,797 ****
  
  : screen-only           ( - )
!    ['] _mtype is type   ['] _emit is emit       ['] crtab is cr ;
  
  : emit-to-file          ( - )
--- 764,768 ----
  
  : screen-only           ( - )
!    ['] _mtype is type   ['] _memit is emit       ['] crtab is cr ;
  
  : emit-to-file          ( - )
***************
*** 819,827 ****
          0                               \ last written time and date not needed
          0                               \ last access time not needed
!         file-time-buf-created           \ creation time needed
          r> call GetFileTime drop
  
!         _systemtime                     \ where to put results
!         file-time-buf                   \ file time/date to convert
          call FileTimeToSystemTime drop
          _systemtime ;
--- 790,798 ----
          0                               \ last written time and date not needed
          0                               \ last access time not needed
!         file-time-buf-created    \ creation time needed
          r> call GetFileTime drop
  
!         _systemtime              \ where to put results
!         file-time-buf            \ file time/date to convert
          call FileTimeToSystemTime drop
          _systemtime ;
***************
*** 833,837 ****
  0 value bufcnt   0 value buffer
  
! : init-buffer   ( - )    2024 DynAlloc to buffer ;
  
  init-buffer  initialization-chain chain-add init-buffer
--- 804,808 ----
  0 value bufcnt   0 value buffer
  
! : init-buffer   ( - )    td 2024 DynAlloc to buffer ;
  
  init-buffer  initialization-chain chain-add init-buffer
***************
*** 889,906 ****
  
  : OpenProcessToken ( - token )
!    here TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY  or call GetCurrentProcess
     call OpenProcessToken drop here @
   ;
  
  : GetEnvironmentVariable  ( zstr-EnvironmentVariable-name buffer n - adr n )
!    swap dup >r rot call GetEnvironmentVariable r> swap ;
  
  : SetEnvironmentVariable  ( zstr-EnvironmentVariable-name  buffer n - )
!    pad +place pad dup +null 1+ swap
     call SetEnvironmentVariable drop
   ;
  
  : DelEnvironmentVariable  ( zstr-EnvironmentVariable-name  - )
!    0 pad ! pad swap
     call SetEnvironmentVariable drop
   ;
--- 860,877 ----
  
  : OpenProcessToken ( - token )
!    here  TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY  or call GetCurrentProcess
     call OpenProcessToken drop here @
   ;
  
  : GetEnvironmentVariable  ( zstr-EnvironmentVariable-name buffer n - adr n )
!    swap dup >r  rot  call GetEnvironmentVariable r> swap ;
  
  : SetEnvironmentVariable  ( zstr-EnvironmentVariable-name  buffer n - )
!    pad +place pad dup +null 1+  swap 
     call SetEnvironmentVariable drop
   ;
  
  : DelEnvironmentVariable  ( zstr-EnvironmentVariable-name  - )
!     0 pad ! pad  swap
     call SetEnvironmentVariable drop
   ;
***************
*** 910,923 ****
   z" TEST"   DelEnvironmentVariable
   z" TEST" s" 2Hello" setEnvironmentVariable
!  z" TEST" buffer 256 GetEnvironmentVariable cr dump abort
! ))
  
  : computername$! ( adr - ) \ March 30th, 2002 was GetComputerName
!    100 pad ! pad \ lpszName
!    over 1+       \ lpdwbuffer
     call GetComputerName drop  pad @ swap c! ;
  
  : username$!     ( adr - )  \ March 30th, 2002  was GetUserName
!    100 pad! pad over 1+ call GetUserName  drop
     pad@ 1- swap c!
    ;
--- 881,893 ----
   z" TEST"   DelEnvironmentVariable
   z" TEST" s" 2Hello" setEnvironmentVariable
!  z" TEST" buffer 256 GetEnvironmentVariable cr dump abort ))
  
  : computername$! ( adr - ) \ March 30th, 2002 was GetComputerName
!    100 pad ! pad   \ lpszName
!    over 1+              \ lpdwbuffer
     call GetComputerName drop  pad @ swap c! ;
  
  : username$!     ( adr - )  \ March 30th, 2002  was GetUserName
!    100 pad! pad  over 1+   call GetUserName  drop
     pad@ 1- swap c!
    ;
***************
*** 939,943 ****
      title$   place title$   +NULL
      r>
!     title$ 1+ message$ 1+
      NULL call MessageBox
   ;
--- 909,913 ----
      title$   place title$   +NULL
      r>
!     title$ 1+  message$ 1+ 
      NULL call MessageBox
   ;
***************
*** 961,965 ****
    0 do i to-cell tmp-array loop  ;
  
! : nrel>abs ( start end -- ...abs )   swap do i tmp-array loop  ;
  
  ((  DWORD  lpAppName,    // points to section name
--- 931,935 ----
    0 do i to-cell tmp-array loop  ;
  
! : n ( start end -- ...abs )   swap do i tmp-array  loop  ;
  
  ((  DWORD  lpAppName,    // points to section name
***************
*** 968,985 ****
      LPTSTR lpReturnedString,    // points to destination buffer
      DWORD nSize,        // size of destination buffer
!     LPCTSTR lpFileName  // points to initialization filename
! ))
  
  \ lpReturnedString will contain a counted string with a 0 at the end
  :  GetPrivateProfileString  ( lpAppName lpKeyName lpDefault lpReturnedString nSize lpFileName - ncopied )
!    1+ 6 to-tmp-array 0 tmp-array 1 tmp-array 2 tmp-array dup >r 1+
!    3 6 nrel>abs  call GetPrivateProfileString r> c! ;
  
  : WritePrivateProfileString  ( lpAppName lpKeyName lpString lpFileName - flag )
!    1+ 4 to-tmp-array  0 4 nrel>abs  call WritePrivateProfileString 0=
     abort" Failed to write profile string."
   ;
  
- 
  create profile$ 256 allot
  
--- 938,953 ----
      LPTSTR lpReturnedString,    // points to destination buffer
      DWORD nSize,        // size of destination buffer
!     LPCTSTR lpFileName  // points to initialization filename  ))
  
  \ lpReturnedString will contain a counted string with a 0 at the end
  :  GetPrivateProfileString  ( lpAppName lpKeyName lpDefault lpReturnedString nSize lpFileName - ncopied )
!    1+ 6 to-tmp-array 0 tmp-array  1 tmp-array 2 tmp-array dup >r 1+
!    3 6 n  call GetPrivateProfileString r> c! ;
  
  : WritePrivateProfileString  ( lpAppName lpKeyName lpString lpFileName - flag )
!    1+ 4 to-tmp-array  0 4 n  call WritePrivateProfileString 0=
     abort" Failed to write profile string."
   ;
  
  create profile$ 256 allot
  
***************
*** 1000,1005 ****
  
  test_WritePrivateProfileString
! test_GetPrivateProfileString profile$ .string \
! ))
  
  : s>tmp$      ( n - adr )     s>d (d.) tmp$ place tmp$  dup 0terminated 1+ ;
--- 968,972 ----
  
  test_WritePrivateProfileString
! test_GetPrivateProfileString profile$ .string \ ))
  
  : s>tmp$      ( n - adr )     s>d (d.) tmp$ place tmp$  dup 0terminated 1+ ;
***************
*** 1063,1070 ****
  
  : ndebug  ( - ) \ shows the normal stack while debugging
!      ['] .s-base is debug-.s ;
  
  previous previous
  
  \ August 21st, 2001 - 11:50
  
--- 1030,1038 ----
  
  : ndebug  ( - ) \ shows the normal stack while debugging
!      ['] .s-base is debug-.s ; 
  
  previous previous
  
+ 
  \ August 21st, 2001 - 11:50
  
***************
*** 1140,1145 ****
  : test foo foo + . ;
  
! cr see test test \
! ))
  
  
--- 1108,1112 ----
  : test foo foo + . ;
  
! cr see test test \ ))
  
  
***************
*** 1190,1194 ****
  : sounds  ( z"sound-file" - )
     sounds_on/off
!      if   SND_FILENAME NULL rot call PlaySound  then drop  ;
  
  \ October 22nd, 2001 - 23:46
--- 1157,1161 ----
  : sounds  ( z"sound-file" - )
     sounds_on/off
!      if   SND_FILENAME NULL rot  call PlaySound  then drop  ;
  
  \ October 22nd, 2001 - 23:46
***************
*** 1196,1207 ****
  also hidden
  
- \ The following 2 definitions allows access to the entire registry.
- \ They are copied from registry.f with a few small changes.
- 
  variable disposition
  variable regkey
  variable regtype
  variable reglen
! named-new$ ReturnedKey$
  
  \ sadr,slen = the registry section to get the key of
--- 1163,1173 ----
  also hidden
  
  variable disposition
  variable regkey
  variable regtype
  variable reglen
! 
! \ The following 2 definitions allows access to the entire registry.
! \ They are copied from registry.f with a few small changes.
  
  \ sadr,slen = the registry section to get the key of
***************
*** 1220,1224 ****
                  NULL
                  0
!                 key$ 1+
                  r> \ root-key
                  Call RegCreateKeyEx
--- 1186,1190 ----
                  NULL
                  0
!                 key$ 1+  
                  r> \ root-key
                  Call RegCreateKeyEx
***************
*** 1241,1249 ****
                  then    >r  drop >r
                  MAXCOUNTED reglen !             \ init max length of string
!                 reglen
!                 ReturnedKey$ 1+
!                 regtype
                  0
!                 r>
                  r@
                  Call RegQueryValueEx
--- 1207,1215 ----
                  then    >r  drop >r
                  MAXCOUNTED reglen !             \ init max length of string
!                 reglen          
!                 ReturnedKey$ 1+ 
!                 regtype         
                  0
!                 r>              
                  r@
                  Call RegQueryValueEx
***************
*** 1263,1268 ****
  \ ( w2k) GetRegistryEntry drop ? ." Mhz" cr
     ;
! test_reg$ \
! ))
  
  \ November 3rd, 2001 - 21:19 added:  u,.  ?u,. ?u,.cr
--- 1229,1233 ----
  \ ( w2k) GetRegistryEntry drop ? ." Mhz" cr
     ;
! test_reg$ \ ))
  
  \ November 3rd, 2001 - 21:19 added:  u,.  ?u,. ?u,.cr
***************
*** 1342,1347 ****
                   ^                       ^
      REG PTR      EBX -->             <-- ECX
!     ESP OFFSET       16  12  8   4   0 
! ))
  
  
--- 1307,1311 ----
                   ^                       ^
      REG PTR      EBX -->             <-- ECX
!     ESP OFFSET       16  12  8   4   0         ))
  
  
***************
*** 1365,1383 ****
           next    c;
  
- 
- \ October 15th, 2002, "Lcc Wizard" Gave me a 2nip in assembler
- 
- CODE 2nip       ( n1 n2 n3 n4 -- n3 n4 ) \ 2swap 2drop
-                 pop     eax
-                 mov     4 [esp], eax
-                 pop     eax
-                 next    c;
- 
  \ October 7th, 2002 - 10:12
  
! : mkdir  ( pSecurityAttributes  z"path" - ior )  call CreateDirectory ;
  
  \ Empty the directory before using rd
! : rd     ( z"path" - ior )                       call RemoveDirectory ;
  
  : -string  ( adr1 cnt1 adr2 cnt2 - adr1+cnt2 cnt1-cnt2 )
--- 1329,1338 ----
           next    c;
  
  \ October 7th, 2002 - 10:12
  
! : mkdir  ( pSecurityAttributes  z"path" - ior )   call CreateDirectory ;
  
  \ Empty the directory before using rd
! : rd     ( z"path" - ior )                        call RemoveDirectory ;
  
  : -string  ( adr1 cnt1 adr2 cnt2 - adr1+cnt2 cnt1-cnt2 )
***************
*** 1527,1531 ****
  [3] -1087358 3 -1
  4293879938  45 53 74                                          ESt ok
! ))
  
  \ June 8th, 2003
--- 1482,1486 ----
  [3] -1087358 3 -1
  4293879938  45 53 74                                          ESt ok
!  ))
  
  \ June 8th, 2003
***************
*** 1538,1542 ****
  &InfoRect 3 cells+ constant height
  
! : windowposition ( hWnd - ) &InfoRect swap  Call GetWindowRect ?win-error ;
  
  250 string: inifile$
--- 1493,1497 ----
  &InfoRect 3 cells+ constant height
  
! : windowposition ( hWnd - ) &InfoRect  swap  Call GetWindowRect ?win-error ;
  
  250 string: inifile$
***************
*** 1561,1565 ****
  [then]
  
  \s
  
! 

[Win32forth-cvs] win32forth/src/lib STRUCT.F,1.7,1.8

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28597/win32forth/src/lib

Modified Files:
	STRUCT.F 
Log Message:
Jos: Corrected the search order.

Index: STRUCT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/STRUCT.F,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** STRUCT.F	28 May 2005 08:35:39 -0000	1.7
--- STRUCT.F	29 May 2005 21:48:52 -0000	1.8
***************
*** 50,55 ****
  \ 12 offset next-offset ( 'adr -- next-offset )
  
- previous
- 
  \s
  
--- 50,53 ----

[Win32forth-cvs] win32forth/src FLOAT.F,1.7,1.8

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31009/win32forth/src

Modified Files:
	FLOAT.F 
Log Message:
gah: added macro 2>fpu to speed up words taking 2 FP inputs

Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** FLOAT.F	24 May 2005 07:53:16 -0000	1.7
--- FLOAT.F	28 May 2005 13:07:38 -0000	1.8
***************
*** 25,28 ****
--- 25,29 ----
  \   also fixed a lot of wrong stack coments
  \ gah Thursday, May 19 2005 optimized fdrop and f2drop for better decoding
+ \ gah Thursday, May 26 2005 added macro 2>FPU
  \ -------------------------------------------------------------------------
  
***************
*** 220,223 ****
--- 221,232 ----
                  endm
  
+ \ macro to move the top 2 values from the seperate float stack into st(0) and st(1)
+ macro: 2>FPU
+                 (>FPU)
+                 sub     ecx, # B/FLOAT
+                 fld     FSIZE FSTACK_MEMORY
+                 mov     FSP_MEMORY , ecx
+                 endm
+ 
  in-application
  
***************
*** 427,432 ****
          
  \ TODO optimize
!                 >FPU
!                 >FPU
                  fxch
                  FPU>
--- 436,440 ----
          
  \ TODO optimize
!                 2>FPU
                  fxch
                  FPU>
***************
*** 838,843 ****
                  fstack-check_2
  
!                 >FPU
!                 >FPU
                  fcompp
                  (fcomp)
--- 846,850 ----
                  fstack-check_2
  
!                 2>FPU
                  fcompp
                  (fcomp)
***************
*** 883,888 ****
                  fstack-check_2
  
!                 >FPU
!                 >FPU
                  faddp   st(1), st
                  FPU>
--- 890,894 ----
                  fstack-check_2
  
!                 2>FPU
                  faddp   st(1), st
                  FPU>
***************
*** 894,899 ****
                  fstack-check_2
  
!                 >FPU
!                 >FPU
                  fxch
                  fsubp   st(1), st
--- 900,904 ----
                  fstack-check_2
  
!                 2>FPU
                  fxch
                  fsubp   st(1), st
***************
*** 906,911 ****
                  fstack-check_2
  
!                 >FPU
!                 >FPU
                  fmulp   st(1), st
                  FPU>
--- 911,915 ----
                  fstack-check_2
  
!                 2>FPU
                  fmulp   st(1), st
                  FPU>
***************
*** 917,922 ****
                  fstack-check_2
  
!                 >FPU
!                 >FPU
                  fxch
                  fdivp   st(1), st
--- 921,925 ----
                  fstack-check_2
  
!                 2>FPU
                  fxch
                  fdivp   st(1), st
***************
*** 929,934 ****
                  fstack-check_2
  
!                 >FPU
!                 >FPU
                  fxch
                  fpatan
--- 932,936 ----
                  fstack-check_2
  
!                 2>FPU
                  fxch
                  fpatan

[Win32forth-cvs] win32forth/apps/Player4 PLAYER4.F,1.12,1.13

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28767/win32forth/apps/Player4

Modified Files:
	PLAYER4.F 
Log Message:
Jos: Removed a small bug from the startup

Index: PLAYER4.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** PLAYER4.F	26 May 2005 08:29:29 -0000	1.12
--- PLAYER4.F	28 May 2005 11:05:31 -0000	1.13
***************
*** 18,23 ****
  decimal
  
! true  value turnkey?
! \ false value turnkey?
  true  value MciDebug?
  
--- 18,23 ----
  decimal
  
! \ true  value turnkey?
!  false value turnkey?
  true  value MciDebug?
  
***************
*** 205,208 ****
--- 205,209 ----
          ['] on_unclicked to unclick-func
  
+ 
          catalog-exist?
          if   map-config-file map-database
***************
*** 211,214 ****
--- 212,216 ----
                    ." freelist: " vadr-config  #free-list @ .
               then
+         else datfile$ count file-exist? not check-config
          then
  
***************
*** 495,501 ****
   DatFile$ count file-exist?  [IF]
   DatFile$ count r/o open-file throw dup file-size throw d>s pad ! close-file throw
!            pad @ sizeof ConfigDef = check-config
!  [ELSE]    DatFile$ create/open  close-file throw
!            0 sizeof ConfigDef = check-config
   [THEN]
  
--- 497,501 ----
   DatFile$ count file-exist?  [IF]
   DatFile$ count r/o open-file throw dup file-size throw d>s pad ! close-file throw
!            pad @ sizeof ConfigDef = check-config unmap-configuration
   [THEN]
  
***************
*** 512,514 ****
  [then]
  \s
! 

[Win32forth-cvs] win32forth/src/lib ExtStruct.f,1.1,1.2 STRUCT.F,1.6,1.7

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15388/win32forth/src/lib

Modified Files:
	ExtStruct.f STRUCT.F 
Log Message:
Jos: Made #struct-size obsolete and minimized struct.f

Index: ExtStruct.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/ExtStruct.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** ExtStruct.f	26 May 2005 08:22:37 -0000	1.1
--- ExtStruct.f	28 May 2005 08:35:39 -0000	1.2
***************
*** 1,14 ****
- \ $Id$
- 
  \ C like structures.
  \ Written by Jos v.d. Ven and Dirk Busch.
! \ Based on Jos's Struct.f
  
  cr .( Loading Extended C like structures... )
  
- [defined] -struct.f [if]
- cr .( Error: You can't use ExtStruct.f and Struct.f in one application. ) abort
- [then]
- 
  anew -ExtStruct.f
  
--- 1,8 ----
  \ C like structures.
  \ Written by Jos v.d. Ven and Dirk Busch.
! \ Based on a previous Struct.f by Jos.
  
  cr .( Loading Extended C like structures... )
  
  anew -ExtStruct.f
  
***************
*** 26,29 ****
--- 20,26 ----
  0 value  _struct
  
+ : _add-struct   ( sizeof.struct -- )  \ compile current offset and increment
+     _struct , +to _struct ;
+ 
  : add-struct    ( sizeof.struct "name" -- )  \ compiling: store current offset and increment
      _struct offset +to _struct ; \ run-time: ( addr -- addr+offset )
***************
*** 91,117 ****
  
  \ Close a struct definiton.
- \ A #STRUCT-SIZE constant is compiled into the vocabulary of the struct.
- \ This constant holds the size of the struct in bytes.
- \ So don't use #STRUCT-SIZE as the name for a struct member !!!
- : ;struct       ( -- )
-         previous
- 
-         s" #struct-size" "HEADER
-         DOCON COMPILE,
-         _struct ,  \ store the size of the struct
  
          previous
          current-voc set-current
          ;
  
- \ Return the size of a struct
- \ The vocabulary for the struct must be in the current search order.
- 
- : struct-size   ( -- n )
-         c" #struct-size" find
-         if   execute
-         else abort" struct-size error"
-         then ;
- 
  : struct-voc[   ( -<name-struct>- -- wid )
         also structs get-current also ' execute ;
--- 88,99 ----
  
  \ Close a struct definiton.
  
+ : ;struct       ( ptr-size -- )
+         previous  _struct swap !  \ Store the size
          previous
          current-voc set-current
+         -1 +to olddepth 
          ;
  
  : struct-voc[   ( -<name-struct>- -- wid )
         also structs get-current also ' execute ;
***************
*** 120,134 ****
          previous previous set-current ;
  
  external
  
  \ return the size of <name-struct> in bytes
- : sizeof        ( -<name-struct>- -- size )
-         struct-voc[
-           struct-size swap
-         ]struct-voc
  
!         state @
          if   postpone literal
!         then ; immediate
  
  \ compiles the adress and offset as one adress inside a definition
--- 102,118 ----
          previous previous set-current ;
  
+ : getsize-struct    ( adr-struct - n )
+         2 cells+ @ ;
+ 
  external
  
+ 
  \ return the size of <name-struct> in bytes
  
! : sizeof        ( -<name-struct>- -- size )
!    ' getsize-struct state @
          if   postpone literal
!         then
!         ; immediate
  
  \ compiles the adress and offset as one adress inside a definition
***************
*** 146,149 ****
--- 130,134 ----
  internal
  
+ 
  : create-struct-voc ( addr len -- wid )
          get-current >r also Structs definitions
***************
*** 151,157 ****
          previous r> set-current ;
  
! : create-struct ( addr len wid -- )
          -rot ( create ) "HEADER DOVAR COMPILE, , immediate
! 
          does> @ +order state @
                if   interpret \ Compile the offset+ part inside a definition
--- 136,142 ----
          previous r> set-current ;
  
! : create-struct ( addr len wid -- ptr-size ) \ Map: WID size
          -rot ( create ) "HEADER DOVAR COMPILE, , immediate
!         here .s  -2 ,
          does> @ +order state @
                if   interpret \ Compile the offset+ part inside a definition
***************
*** 165,169 ****
  \ A vocabulary <name-struct> is created.
  \ All words for the struct members will be compiled into this vocabulary.
! : :struct       ( -<name-struct>- -- )
          /parse-word count ( addr len )
          
--- 150,154 ----
  \ A vocabulary <name-struct> is created.
  \ All words for the struct members will be compiled into this vocabulary.
! : :struct       ( -<name-struct>- -- ptr-size )
          /parse-word count ( addr len )
          
***************
*** 180,183 ****
--- 165,169 ----
  
          0 to _struct
+         1 +to olddepth
          ;
  
***************
*** 317,319 ****
  decimal
  
! 

[Win32forth-cvs] win32forth/apps/Player4 Catalog.f,1.7,1.8 Mediatree.f,1.10,1.11 PLAYER4.F,1.11,1.12 Pl_MciWindow.f,1.8,1.9 TrayWindow.f,1.2,1.3

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22449/apps/Player4

Modified Files:
	Catalog.f Mediatree.f PLAYER4.F Pl_MciWindow.f TrayWindow.f 
Log Message:
Changed Player4 to work with ExtStruct.f instead Struct.f to make ExtStruct.f work within real applications.

Index: PLAYER4.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -d -r1.11 -r1.12
*** PLAYER4.F	15 May 2005 17:21:52 -0000	1.11
--- PLAYER4.F	26 May 2005 08:29:29 -0000	1.12
***************
*** 37,41 ****
  needs sub_dirs.f
  needs number.f
- needs struct.f
  needs w_search.f
  needs shell_r.f
--- 37,40 ----

Index: Catalog.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Catalog.f,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** Catalog.f	16 May 2005 16:18:13 -0000	1.7
--- Catalog.f	26 May 2005 08:29:29 -0000	1.8
***************
*** 1,5 ****
  anew catalog.f  \ 4-4-2005
  
! needs struct.f
  needs w_search.f
  needs shell_r.f
--- 1,6 ----
  anew catalog.f  \ 4-4-2005
  
! needs ExtStruct.f
! needs Pl_Toolset.f
  needs w_search.f
  needs shell_r.f
***************
*** 15,19 ****
  \ Define the configuration of the database
  
! struct{ \ ConfigDef in PathMediaFiles.dat
                  MAX-PATH    Field:      PathMediaFiles
                  DWORD                   #free-list
--- 16,20 ----
  \ Define the configuration of the database
  
! :struct ConfigDef \ ConfigDef in PathMediaFiles.dat
                  MAX-PATH    Field:      PathMediaFiles
                  DWORD                   #free-list
***************
*** 21,27 ****
                  DWORD                   first-free-record
                  DWORD                   MaximumRandomLevel
! }struct ConfigDef
  
! sizeof ConfigDef  mkstruct: Config      s" \" Config PathMediaFiles place
  create DatFile$ ," PathMediaFiles.dat"  sizeof  ConfigDef allot
  
--- 22,28 ----
                  DWORD                   first-free-record
                  DWORD                   MaximumRandomLevel
! ;struct
  
! sizeof ConfigDef  mkstruct: Config      s" \" Config ConfigDef PathMediaFiles place
  create DatFile$ ," PathMediaFiles.dat"  sizeof  ConfigDef allot
  
***************
*** 32,36 ****
   36 constant /Title
  
! struct{ \ catalog
                  /file_name  Field:      File_name
                  BYTE                    Cnt_File_name
--- 33,37 ----
   36 constant /Title
  
! :struct RecordDef \ catalog
                  /file_name  Field:      File_name
                  BYTE                    Cnt_File_name
***************
*** 48,52 ****
                  DWORD                   #played
                  DWORD                   Not_used1
! }struct RecordDef
  
  \ database part
--- 49,53 ----
                  DWORD                   #played
                  DWORD                   Not_used1
! ;struct
  
  \ database part
***************
*** 151,161 ****
    ;
  
! : in-freelist? ( adr - flag ) s" Deleted- c@ " EVALUATE ; IMMEDIATE
  
  : free-list-check  ( n - )
     n>record  dup in-freelist?
       if   vadr-config >r  record>r dup  r@ #free-list @ 0=
!                 if     dup r@ first-free-record ! dup r>record Deleted-thread !
!                 else   r@ prev-free-record @ r>record Deleted-thread !
                  then
             r@ prev-free-record !  1 r> #free-list +!
--- 152,162 ----
    ;
  
! : in-freelist? ( adr - flag ) s" RecordDef Deleted- c@ " EVALUATE ; IMMEDIATE
  
  : free-list-check  ( n - )
     n>record  dup in-freelist?
       if   vadr-config >r  record>r dup  r@ #free-list @ 0=
!                 if     dup r@ first-free-record ! dup r>record RecordDef Deleted-thread !
!                 else   r@ prev-free-record @ r>record RecordDef Deleted-thread !
                  then
             r@ prev-free-record !  1 r> #free-list +!
***************
*** 165,169 ****
  
  : next-in-freelist ( vadr-config - rel-ptr )
!     first-free-record @ r>record Deleted-thread @
    ;
  
--- 166,170 ----
  
  : next-in-freelist ( vadr-config - rel-ptr )
!     first-free-record @ r>record RecordDef Deleted-thread @
    ;
  
***************
*** 181,195 ****
  
  : delete-record   ( n - )
!    dup true swap n>record dup>r Deleted- c!
!    0 r> Excluded- c!
     free-list-check
   ;
  
  : mark-as-undeleted ( adr - )
!     false 2dup swap  Deleted- c!
!     swap 2dup Excluded- c!
!                   2dup RandomLevel !
!                   2dup #played !
!                        Played- c!
    ;
  
--- 182,196 ----
  
  : delete-record   ( n - )
!    dup true swap n>record dup>r RecordDef Deleted- c!
!    0 r> RecordDef Excluded- c!
     free-list-check
   ;
  
  : mark-as-undeleted ( adr - )
!     false 2dup swap RecordDef Deleted- c!
!     swap 2dup RecordDef Excluded- c!
!     2dup RecordDef RandomLevel !
!     2dup RecordDef #played !
!          RecordDef Played- c!
    ;
  
***************
*** 198,202 ****
  : undelete-all ( - )
      vadr-config first-free-record @  vadr-config #free-list @ 0
!       ?do    r>record dup Deleted-thread @ swap mark-as-undeleted
        loop
       drop build-free-list
--- 199,203 ----
  : undelete-all ( - )
      vadr-config first-free-record @  vadr-config #free-list @ 0
!       ?do    r>record dup RecordDef Deleted-thread @ swap mark-as-undeleted
        loop
       drop build-free-list
***************
*** 206,210 ****
  
  : delete-record-in-collection ( n - )
!     dup n>record Excluded- c@ 0=
           if      delete-record
           else    drop
--- 207,211 ----
  
  : delete-record-in-collection ( n - )
!     dup n>record RecordDef Excluded- c@ 0=
           if      delete-record
           else    drop
***************
*** 225,247 ****
   ;
  
! : by_FileName ( - )     /file_name  to key-len  0 File_name    to key-start ;
! : by_FileSize ( - )     1 cells     to key-len  0 FileSize     to key-start ;
  
! : not-deleted? ( rec-adr - flag )   s" deleted- c@ 0= " EVALUATE ; IMMEDIATE
  
  : _list-record ( rec-adr - )
      dup>r not-deleted?
          if      cr r@ .
!                 r@ File_name r@   Cnt_File_name c@   type-space
!                 r@ #played ?
!                 r@ RandomLevel ?
!                 r@ Played- c@ .
!                 r@ Excluded- c@ .
!                 r@ FileSize @ 12  U,.R
          then
      r>drop
     ;
  
! : record-not-played     ( n - )  n>record 0 swap Played- c! ;
  : set-all-not-played    ( - )    0  for-all-records-from# record-not-played ;
  
--- 226,248 ----
   ;
  
! : by_FileName ( - )     /file_name  to key-len  0 RecordDef File_name    to key-start ;
! : by_FileSize ( - )     1 cells     to key-len  0 RecordDef FileSize     to key-start ;
  
! : not-deleted? ( rec-adr - flag )   s" RecordDef deleted- c@ 0= " EVALUATE ; IMMEDIATE
  
  : _list-record ( rec-adr - )
      dup>r not-deleted?
          if      cr r@ .
!                 r@ RecordDef File_name r@   Cnt_File_name c@   type-space
!                 r@ RecordDef #played ?
!                 r@ RecordDef RandomLevel ?
!                 r@ RecordDef Played- c@ .
!                 r@ RecordDef Excluded- c@ .
!                 r@ RecordDef FileSize @ 12  U,.R
          then
      r>drop
     ;
  
! : record-not-played     ( n - )  n>record 0 swap RecordDef Played- c! ;
  : set-all-not-played    ( - )    0  for-all-records-from# record-not-played ;
  
***************
*** 250,262 ****
  : list-database ( - )   map-database  list-records unmap-database ;
  
! : change-randomlevel    ( level n - )  n>record over random swap RandomLevel  ! ;
  : sort_by_filename      ( - )    by_FileName sort-database  ;
  : sort_by_filesize      ( - )    by_FileSize sort-database-bin  ;
  
  : sort-by_RandomLevel ( - )
!         1 cells         to key-len
!         0 #played       to key-start  sort-database-bin
!         0 RandomLevel   to key-start  sort-database-bin
!         0 Deleted-      to key-start  sort-database-bin
  
    ;
--- 251,263 ----
  : list-database ( - )   map-database  list-records unmap-database ;
  
! : change-randomlevel    ( level n - )  n>record over random swap RecordDef RandomLevel  ! ;
  : sort_by_filename      ( - )    by_FileName sort-database  ;
  : sort_by_filesize      ( - )    by_FileSize sort-database-bin  ;
  
  : sort-by_RandomLevel ( - )
!         1 cells                  to key-len
!         0 RecordDef #played      to key-start  sort-database-bin
!         0 RecordDef RandomLevel  to key-start  sort-database-bin
!         0 RecordDef Deleted-     to key-start  sort-database-bin
  
    ;
***************
*** 267,272 ****
     ;
  
! : incr-#played  ( adr - ) #played dup @ 1+ swap ! ;
! : mark-played   ( adr - ) -1 swap Played- c!      ;
  
  internal
--- 268,273 ----
     ;
  
! : incr-#played  ( adr - ) RecordDef #played dup @ 1+ swap ! ;
! : mark-played   ( adr - ) -1 swap RecordDef Played- c!      ;
  
  internal
***************
*** 281,289 ****
  : (add-file)    ( wHndl addr len file-size - wHndl ) \ add a file to the catalog
     InlineRecord [ sizeof RecordDef ] literal erase
!                 >struct InlineRecord FileSize           !
     >r
!                 >struct InlineRecord File_name          r@ cmove
!    r@           >struct InlineRecord Cnt_File_name      c!
!    100 random   >struct InlineRecord RandomLevel        !
     r>drop
     dup write-record
--- 282,290 ----
  : (add-file)    ( wHndl addr len file-size - wHndl ) \ add a file to the catalog
     InlineRecord [ sizeof RecordDef ] literal erase
!                 struct, InlineRecord RecordDef FileSize           !
     >r
!                 struct, InlineRecord RecordDef File_name          r@ cmove
!    r@           struct, InlineRecord RecordDef Cnt_File_name      c!
!    100 random   struct, InlineRecord RecordDef RandomLevel        !
     r>drop
     dup write-record
***************
*** 303,307 ****
  : next-not-played ( - n ) \ -1 means done.
          -1 #records last-selected-rec     \ Starting from the last-selected record
!         do   i n>record dup Excluded- c@ not swap Played- c@ 0= and
               if   drop i leave
               then
--- 304,308 ----
  : next-not-played ( - n ) \ -1 means done.
          -1 #records last-selected-rec     \ Starting from the last-selected record
!         do   i n>record dup RecordDef Excluded- c@ not swap RecordDef Played- c@ 0= and
               if   drop i leave
               then
***************
*** 319,326 ****
          database$ count file-exist?     and
          \ database-mhndl map-file-open?   or
          MciDebug?
!            if   cr ." catalog-exist? " dup .
!            then
!  ;
  
  \ --------------------------------------------------------------------------
--- 320,329 ----
          database$ count file-exist?     and
          \ database-mhndl map-file-open?   or
+ [defined] MciDebug? [if]
          MciDebug?
!         if   cr ." catalog-exist? " dup .
!         then
! [then]
!         ;
  
  \ --------------------------------------------------------------------------
***************
*** 356,360 ****
  : search-record ( arg-adr$ count #rec - arg-adr$ count )
     n>record dup>r record-size 2over 2swap false *search
!    not nip nip r> Excluded- c!
   ;
  
--- 359,363 ----
  : search-record ( arg-adr$ count #rec - arg-adr$ count )
     n>record dup>r record-size 2over 2swap false *search
!    not nip nip r> RecordDef Excluded- c!
   ;
  
***************
*** 389,391 ****
  \ debug ask-max-random-level
  \s
! 

[Win32forth-cvs] win32forth/apps/PlayVirginRadio PlayVirginRadio.f,1.1,1.2

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/PlayVirginRadio
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22449/apps/PlayVirginRadio

Modified Files:
	PlayVirginRadio.f 
Log Message:
Changed Player4 to work with ExtStruct.f instead Struct.f to make ExtStruct.f work within real applications.

Index: PlayVirginRadio.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/PlayVirginRadio/PlayVirginRadio.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** PlayVirginRadio.f	22 May 2005 10:22:28 -0000	1.1
--- PlayVirginRadio.f	26 May 2005 08:29:29 -0000	1.2
***************
*** 13,17 ****
  anew -PlayVirginRadio.f
  
- needs struct.f
  needs apps\Player4\TrayWindow.f
  needs HtmlDisplayControl.f
--- 13,16 ----

[Win32forth-cvs] win32forth/src/lib ExtStruct.f,NONE,1.1 STRUCT.F,1.5,1.6

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21015/src/lib

Modified Files:
	STRUCT.F 
Added Files:
	ExtStruct.f 
Log Message:
New structure package ExtStruct.f added

--- NEW FILE: ExtStruct.f ---
\ $Id: ExtStruct.f,v 1.1 2005/05/26 08:22:37 dbu_de Exp $

\ C like structures.
\ Written by Jos v.d. Ven and Dirk Busch.
\ Based on Jos's Struct.f

cr .( Loading Extended C like structures... )

[defined] -struct.f [if]
cr .( Error: You can't use ExtStruct.f and Struct.f in one application. ) abort
[then]

anew -ExtStruct.f

in-system

\ The following memory allocation words allow nesting and cloning
\ of a memory structure. Definitions made in C can be used with
\ small modifications. Use mkstruct: to allocate memory.

vocabulary Structs \ all vocabularies for the struct's go in this one
private    Structs \ and avoids name conflicts. e.g. word

internal

0 value  _struct

: add-struct    ( sizeof.struct "name" -- )  \ compiling: store current offset and increment
    _struct offset +to _struct ; \ run-time: ( addr -- addr+offset )

: byte          ( -- )       \ compiling: store offset and increment _struct by 1
   1 add-struct ;            \ run-time: ( offset - offset+dword ) immediate

: word          ( -- )       \ compiling: store offset and increment _struct by 2
   2 add-struct  ;           \ run-time: ( offset - offset+dword ) immediate

: dword         ( -- )       \ compiling: store offset and increment _struct by 4
   4 add-struct ;            \ run-time: ( offset - offset+dword ) immediate

: double        ( -- )       \ compiling: store offset and increment _struct by 8
   8 add-struct ;            \ run-time: ( offset - offset+dword ) immediate

: long_double   ( -- )       \ compiling: store offset and increment _struct by 10
   10 add-struct ;           \ run-time: ( offset - offset+dword ) immediate

: guid          ( -- )       \ compiling: store offset and increment _struct by 16
   16 add-struct ;           \ run-time: ( offset - offset+dword ) immediate

: qword         ( -- )       \ compiling: store offset and increment _struct by 32
   32 add-struct ;           \ run-time: ( offset - offset+dword ) immediate

: unsigned ;                 \ 0 can be ignored when allocating

' byte  alias char  \ 1 byte

\ Note: Changed INT and UINT to 4 bytes, because INT's are 32 Bit's long
\ under Windows (Samstag, Mai 29 2004 - 20:13 dbu)
' word  alias short \ 2 bytes
' word  alias ushort
' word  alias wchar

' dword alias long  \ 4 bytes
' dword alias int
' dword alias uint
' dword alias ulong
' dword alias langid
' dword alias lpvoid
' dword alias float

' add-struct alias field:

\ Not standard in C

' dword alias HWND  \ 4 bytes
' dword alias HICON \ 4 bytes

[DEFINED] b/float [IF]

: b/float                       \ compile-time: ( - )   \ 8 or 10
        b/float add-struct ;    \ run-time: ( offset - offset+dword )

[THEN]

: cell                          \ compile-time: ( - )  \ Forth depended
        cell add-struct ;       \ run-time: ( offset - offset+dword )

: offset                        \ compile-time: ( - ) It is a kind of label
        _struct offset ;        \ run-time: ( offset - offset+dword )

0 value current-voc 

\ Close a struct definiton.
\ A #STRUCT-SIZE constant is compiled into the vocabulary of the struct.
\ This constant holds the size of the struct in bytes.
\ So don't use #STRUCT-SIZE as the name for a struct member !!!
: ;struct       ( -- )
        previous

        s" #struct-size" "HEADER
        DOCON COMPILE,
        _struct ,  \ store the size of the struct

        previous
        current-voc set-current
        ;

\ Return the size of a struct
\ The vocabulary for the struct must be in the current search order.

: struct-size   ( -- n )
        c" #struct-size" find
        if   execute
        else abort" struct-size error"
        then ;

: struct-voc[   ( -<name-struct>- -- wid )
       also structs get-current also ' execute ;

: ]struct-voc   ( wid -- )
        previous previous set-current ;

external

\ return the size of <name-struct> in bytes
: sizeof        ( -<name-struct>- -- size )
        struct-voc[
          struct-size swap
        ]struct-voc

        state @
        if   postpone literal
        then ; immediate

\ compiles the adress and offset as one adress inside a definition
: struct, ( -<Struct>- -<name-struct>- -<member>- -- )
        ' execute          \ struct_adress

        struct-voc[
          swap
          ' execute        \ struct_adress + offset_in_structure
          postpone literal
        ]struct-voc

        ; immediate

internal

: create-struct-voc ( addr len -- wid )
        get-current >r also Structs definitions
        >SYSTEM "HEADER dovoc , #threads #WORDLIST SYSTEM> ( wid )
        previous r> set-current ;

: create-struct ( addr len wid -- )
        -rot ( create ) "HEADER DOVAR COMPILE, , immediate

        does> @ +order state @
              if   interpret \ Compile the offset+ part inside a definition
                   previous  \ and restore the order
              then                     
        ;

external

\ Open a struct definition.
\ A vocabulary <name-struct> is created.
\ All words for the struct members will be compiled into this vocabulary.
: :struct       ( -<name-struct>- -- )
        /parse-word count ( addr len )
        
        \ create the vocabulary for the struct in the 'structs' vocabulary
        2dup create-struct-voc ( addr len wid )

        \ create a immediate word in current dict. That compiles the
        \ offset + part inside a definition at runtime
        dup>r create-struct r> ( wid )

        get-current to current-voc
        also set-current ( -- )
        also Structs

        0 to _struct
        ;

\ create a struct in the dictionary and fill it with zero's
: mkstruct:     ( size-struct <-name-> -- )
        create here over allot swap erase ;

in-application

module

\s ----------------------------------------------------------------------------
\ Test
\ -----------------------------------------------------------------------------
hex

cls

order

cr .( def: s1)
:struct s1
        byte b1
        word w1
        long l1
;struct

cr .( def: s2)
:struct s2
        long l1
        byte b1
        word w1
        int  i1
;struct

order

0 constant relative

cr .( Testing: s1)
cr .( sizeof: ) sizeof s1 .
cr .( makestruct: ) sizeof s1 mkstruct: struct1
struct1 sizeof s1 dump
order

s1
order

cr .( rel. positions and adresses: )
cr relative b1 . struct1 b1 .
cr relative w1 . struct1 w1 .
cr relative l1 . struct1 l1 .

cr .( fill-struct: )
11       struct1 b1 c!
2222     struct1 w1 w!
33333333 struct1 l1 !
struct1 sizeof s1 dump

previous
order

cr .( Testing: s2)
cr .( sizeof: ) sizeof s2 .
cr .( makestruct: ) sizeof s2 mkstruct: struct2
struct2 sizeof s2 dump
order

s2
order

cr .( rel. positions and adresses: )
cr relative l1 . struct2 l1 .
cr relative b1 . struct2 b1 .
cr relative w1 . struct2 w1 .
cr relative i1 . struct2 i1 .

cr .( fill-struct: )
33333333 struct2 l1 !
11       struct2 b1 c!
2222     struct2 w1 w!
44444444 struct2 i1 !
struct2 sizeof s2 dump

previous
order

cr .( Test compiling of struct-member-offsets )
: test
    55       struct1 s1 b1 c!
    6666     struct1 s1 w1 w!
    77777777 struct1 s1 l1  !

    77777777 struct2 s2 l1  !
    55       struct2 s2 b1 c!
    6666     struct2 s2 w1 w!
    88888888 struct2 s2 i1  !
;

see test
test
struct1 sizeof s1 dump
struct2 sizeof s2 dump

cr .( Test compiling of struct-member-offsets )
: test1
    11       struct, struct1 s1 b1 c!
    2222     struct, struct1 s1 w1 w!
    33333333 struct, struct1 s1 l1  !

    33333333 struct, struct2 s2 l1  !
    11       struct, struct2 s2 b1 c!
    2222     struct, struct2 s2 w1 w!
    44444444 struct, struct2 s2 i1  !
;

see test1
test1
struct1 sizeof s1 dump
struct2 sizeof s2 dump

cr .( Test sizeof inside a definition )
: test-sizeof
        cr ." sizeof s1: " [ sizeof s1 ] literal .
        cr ." sizeof s2: " [ sizeof s2 ] literal .
        ;
test-sizeof

: test-sizeof1
        cr ." sizeof s1: " sizeof s1 .
        cr ." sizeof s2: " sizeof s2 .
        ;
test-sizeof1

cr order

decimal

[Win32forth-cvs] win32forth/src REGISTRY.F,1.5,1.6

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4680/src

Modified Files:
	REGISTRY.F 
Log Message:
- Some more changes to work with Rod's RegistrySupport.f

Index: REGISTRY.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/REGISTRY.F,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** REGISTRY.F	24 May 2005 15:54:01 -0000	1.5
--- REGISTRY.F	25 May 2005 15:40:53 -0000	1.6
***************
*** 12,19 ****
  \ Sonntag, Dezember 26 2004 dbu mostly rewritten
  \ Dienstag, Mai 24 2005 dbu 
! \   - Changed to work with Rod's RegistrySupport.f and
  \   - fixed a bug in (RegQueryValue)      
  \   - removed the deprecated words .REGISTRY and RE-REGISTER
  \   - Expanded TAB's into spaces
  
  cr .( Loading Windows Registry...)
--- 12,21 ----
  \ Sonntag, Dezember 26 2004 dbu mostly rewritten
  \ Dienstag, Mai 24 2005 dbu 
! \   - Changed to work with Rod's RegistrySupport.f
  \   - fixed a bug in (RegQueryValue)      
  \   - removed the deprecated words .REGISTRY and RE-REGISTER
  \   - Expanded TAB's into spaces
+ \ Mittwoch, Mai 25 2005 dbu 
+ \   - Some more changes to work with Rod's RegistrySupport.f
  
  cr .( Loading Windows Registry...)
***************
*** 117,121 ****
  \ sadr,slen = the registry section to get the key of  (for read accesss)
  \ return -1 if we could not get the key
! : RegGetKey     { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
                  regBaseKey
--- 119,123 ----
  \ sadr,slen = the registry section to get the key of  (for read accesss)
  \ return -1 if we could not get the key
! : RegGetKeyRead { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
                  regBaseKey
***************
*** 135,140 ****
                  ReturnedKey$ off                \ initially clear return buffer
  
!                 sadr slen RegGetKey dup INVALID_HANDLE_VALUE =
!                 if   drop ReturnedKey$ count
                       EXIT \ return on error, empty data
                  then
--- 137,142 ----
                  ReturnedKey$ off                \ initially clear return buffer
  
!                 sadr slen RegGetKeyRead dup INVALID_HANDLE_VALUE =
!                 if   drop ReturnedKey$ count regLen off regType off
                       EXIT \ return on error, empty data
                  then
***************
*** 158,162 ****
  \ sadr,slen = the registry section to get the key of (for write accesss)
  \ return -1 if we could not get the key
! : RegGetKeyWrite { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
                  regBaseKey
--- 160,164 ----
  \ sadr,slen = the registry section to get the key of (for write accesss)
  \ return -1 if we could not get the key
! : RegGetKey     { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
                  regBaseKey
***************
*** 171,175 ****
  : RegSetString  { dadr dlen vadr vlen sadr slen \ val$ khdl -- }
  
!                 sadr slen RegGetKeyWrite to khdl
                  khdl INVALID_HANDLE_VALUE =
                  if exit then \ just return, ignore error
--- 173,177 ----
  : RegSetString  { dadr dlen vadr vlen sadr slen \ val$ khdl -- }
  
!                 sadr slen RegGetKey to khdl
                  khdl INVALID_HANDLE_VALUE =
                  if exit then \ just return, ignore error

[Win32forth-cvs] win32forth/src REGISTRY.F,1.4,1.5

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9782/src

Modified Files:
	REGISTRY.F 
Log Message:
- Changed to work with Rod's RegistrySupport.f 
- fixed a bug in (RegQueryValue)      
- removed the deprecated words .REGISTRY and RE-REGISTER
- Expanded TAB's into spaces

Index: REGISTRY.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/REGISTRY.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** REGISTRY.F	17 May 2005 22:25:25 -0000	1.4
--- REGISTRY.F	24 May 2005 15:54:01 -0000	1.5
***************
*** 11,19 ****
  \ 2003/09/08 dbu removed the registry entries 'Directory' and 'Version'
  \ Sonntag, Dezember 26 2004 dbu mostly rewritten
  
  cr .( Loading Windows Registry...)
  
- \ anew -Registry.f
- 
  INTERNAL
  
--- 11,22 ----
  \ 2003/09/08 dbu removed the registry entries 'Directory' and 'Version'
  \ Sonntag, Dezember 26 2004 dbu mostly rewritten
+ \ Dienstag, Mai 24 2005 dbu 
+ \   - Changed to work with Rod's RegistrySupport.f and
+ \   - fixed a bug in (RegQueryValue)      
+ \   - removed the deprecated words .REGISTRY and RE-REGISTER
+ \   - Expanded TAB's into spaces
  
  cr .( Loading Windows Registry...)
  
  INTERNAL
  
***************
*** 33,74 ****
  
  \ RegOpenKey opens the specified registry key
! : (RegOpenKey)	{ hKey lpSubKey samDesired \ hkResult -- hkResult }
!  		&OF hkResult samDesired 0 lpSubKey hKey
! 		call RegOpenKeyEx ERROR_SUCCESS =
! 		if hkResult else INVALID_HANDLE_VALUE then ;
  
  \ RegCreateKey creates the specified registry key.
  \ If the key already exists, it is opened.
  : (RegCreateKey) { hKey lpSubKey samDesired \ Class Disposition hkResult -- hkResult }
! 		0 to Class
! 		0 to Disposition
! 
! 		&OF Disposition         \ disposition value buffer
! 		&OF hkResult            \ key handle
! 		0                       \ inheritance
! 		samDesired              \ desired security access
! 		REG_OPTION_NON_VOLATILE \ special options
! 		&OF Class               \ class string
! 		0                       \ reserved
! 		lpSubKey                \ subkey name
! 		hKey                    \ handle to open key
! 
! 		call RegCreateKeyEx ERROR_SUCCESS =
! 		if hkResult else INVALID_HANDLE_VALUE then ;
  
  \ RegCloseKey releases a handle to the specified registry key
! : (RegCloseKey)	( hKey -- f )
! 		call RegCloseKey ERROR_SUCCESS = ;
  
  \ RegQueryValue retrieves the type and data for a specified value name
  \ associated with an open registry key
  : (RegQueryValue) { hKey lpValueName rType lpData lpcbData \ -- f }
! 		lpcbData lpData &OF rType null
! 		lpValueName hKey call RegQueryValueEx ERROR_SUCCESS = ;
  
  \ RegSetValue sets the data and type of a specified value under a registry key.
! : (RegSetValue)	{ hKey lpValueName rType lpData cbData \ -- f }
! 		cbData lpData rType null
! 		lpValueName hKey call RegSetValueEx ERROR_SUCCESS = ;
  
  \ ************************************************************************************
--- 36,77 ----
  
  \ RegOpenKey opens the specified registry key
! : (RegOpenKey)  { hKey lpSubKey samDesired \ hkResult -- hkResult }
!                 &OF hkResult samDesired 0 lpSubKey hKey
!                 call RegOpenKeyEx ERROR_SUCCESS =
!                 if hkResult else INVALID_HANDLE_VALUE then ;
  
  \ RegCreateKey creates the specified registry key.
  \ If the key already exists, it is opened.
  : (RegCreateKey) { hKey lpSubKey samDesired \ Class Disposition hkResult -- hkResult }
!                 0 to Class
!                 0 to Disposition
!                 
!                 &OF Disposition         \ disposition value buffer
!                 &OF hkResult            \ key handle
!                 0                       \ inheritance
!                 samDesired              \ desired security access
!                 REG_OPTION_NON_VOLATILE \ special options
!                 &OF Class               \ class string
!                 0                       \ reserved
!                 lpSubKey                \ subkey name
!                 hKey                    \ handle to open key
!                 
!                 call RegCreateKeyEx ERROR_SUCCESS =
!                 if hkResult else INVALID_HANDLE_VALUE then ;
  
  \ RegCloseKey releases a handle to the specified registry key
! : (RegCloseKey) ( hKey -- f )
!                 call RegCloseKey ERROR_SUCCESS = ;
  
  \ RegQueryValue retrieves the type and data for a specified value name
  \ associated with an open registry key
  : (RegQueryValue) { hKey lpValueName rType lpData lpcbData \ -- f }
!                 lpcbData lpData rType null
!                 lpValueName hKey call RegQueryValueEx ERROR_SUCCESS = ;
  
  \ RegSetValue sets the data and type of a specified value under a registry key.
! : (RegSetValue) { hKey lpValueName rType lpData cbData \ -- f }
!                 cbData lpData rType null
!                 lpValueName hKey call RegSetValueEx ERROR_SUCCESS = ;
  
  \ ************************************************************************************
***************
*** 85,94 ****
  
  : PROGREG-SET-BASE-PATH ( -- )
! 		s" Win32Forth " ProgReg place
! 		version# ((version)) ProgReg +place
! 		s" \" ProgReg +place ;
  
! : PROGREG-INIT	( -- )
! 		PROGREG-SET-BASE-PATH s" Win32For\" ProgReg +place ;
  
  initialization-chain chain-add PROGREG-INIT
--- 88,97 ----
  
  : PROGREG-SET-BASE-PATH ( -- )
!                 s" Win32Forth " ProgReg place
!                 version# ((version)) ProgReg +place
!                 s" \" ProgReg +place ;
  
! : PROGREG-INIT  ( -- )
!                 PROGREG-SET-BASE-PATH s" Win32For\" ProgReg +place ;
  
  initialization-chain chain-add PROGREG-INIT
***************
*** 101,121 ****
  
  variable regLen
  named-new$ ReturnedKey$
  
! : BuildSection	( sadr slen adr -- adr1 )
! 		>R
                  BaseReg count r@  place
                  ProgReg count r@ +place
                                r@ +place
                                r@ +NULL
! 		r> 1+ ;
  
  \ sadr,slen = the registry section to get the key of  (for read accesss)
  \ return -1 if we could not get the key
! : RegGetKeyRead { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
! 		regBaseKey
! 		sadr slen section$ BuildSection
! 		regAccessMask (RegOpenKey) ;
  
  external
--- 104,125 ----
  
  variable regLen
+ variable regType
  named-new$ ReturnedKey$
  
! : BuildSection  ( sadr slen adr -- adr1 )
!                 >R
                  BaseReg count r@  place
                  ProgReg count r@ +place
                                r@ +place
                                r@ +NULL
!                 r> 1+ ;
  
  \ sadr,slen = the registry section to get the key of  (for read accesss)
  \ return -1 if we could not get the key
! : RegGetKey     { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
!                 regBaseKey
!                 sadr slen section$ BuildSection
!                 regAccessMask (RegOpenKey) ;
  
  external
***************
*** 128,146 ****
  \ vadr,vlen = the registry key value string to read
  \ dadr,dlen = the registry key data string returned
! : RegGetString  { vadr vlen sadr slen \ regType -- dadr dlen }
                  ReturnedKey$ off                \ initially clear return buffer
  
!                 sadr slen RegGetKeyRead dup INVALID_HANDLE_VALUE =
                  if   drop ReturnedKey$ count
                       EXIT \ return on error, empty data
                  then
  
! 		dup
! 		vadr
! 		&OF regType               \ we get it, but we don't need it
                  ReturnedKey$ 1+
                  MAXCOUNTED regLen !             \ init max length of string
                  regLen
! 		(RegQueryValue)
  
                  if   regLen @ 1- 0max ReturnedKey$ c! \ make counted string
--- 132,150 ----
  \ vadr,vlen = the registry key value string to read
  \ dadr,dlen = the registry key data string returned
! : RegGetString  { vadr vlen sadr slen -- dadr dlen }
                  ReturnedKey$ off                \ initially clear return buffer
  
!                 sadr slen RegGetKey dup INVALID_HANDLE_VALUE =
                  if   drop ReturnedKey$ count
                       EXIT \ return on error, empty data
                  then
  
!                 dup
!                 vadr
!                 regType                   \ we get it, but we don't need it
                  ReturnedKey$ 1+
                  MAXCOUNTED regLen !             \ init max length of string
                  regLen
!                 (RegQueryValue)
  
                  if   regLen @ 1- 0max ReturnedKey$ c! \ make counted string
***************
*** 148,152 ****
                  then (RegCloseKey) drop
  
! 		ReturnedKey$ count ;
  
  internal
--- 152,156 ----
                  then (RegCloseKey) drop
  
!                 ReturnedKey$ count ;
  
  internal
***************
*** 156,162 ****
  : RegGetKeyWrite { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
! 		regBaseKey
! 		sadr slen section$ BuildSection
! 		regAccessMask (RegCreateKey) ;
  
  external
--- 160,166 ----
  : RegGetKeyWrite { sadr slen \ section$ -- regkey }  \ read the key of a section
                  MAXSTRING 2 + LocalAlloc: section$
!                 regBaseKey
!                 sadr slen section$ BuildSection
!                 regAccessMask (RegCreateKey) ;
  
  external
***************
*** 175,184 ****
                            val$ +NULL
  
! 		khdl
! 		vadr
                  REG_SZ                       \ type
                  val$ 1+                      \ null terminated data string
                  dlen 1+                      \ data length including NULL
! 		(RegSetValue) drop
  
                  khdl (RegCloseKey) drop ;
--- 179,188 ----
                            val$ +NULL
  
!                 khdl
!                 vadr
                  REG_SZ                       \ type
                  val$ 1+                      \ null terminated data string
                  dlen 1+                      \ data length including NULL
!                 (RegSetValue) drop
  
                  khdl (RegCloseKey) drop ;
***************
*** 190,198 ****
                  s" Settings" RegGetString ;
  
! : .registry     ( -- )
!                 cr ." Console location:" s" Console" GetSetting type ; DEPRECATED
  
! : re-register   ( -- )
!                 .registry ; DEPRECATED
  
  INTERNAL
--- 194,202 ----
                  s" Settings" RegGetString ;
  
! \ : .registry     ( -- )
! \                 cr ." Console location:" s" Console" GetSetting type ; DEPRECATED
  
! \ : re-register   ( -- )
! \                 .registry ; DEPRECATED
  
  INTERNAL
***************
*** 227,229 ****
  : test!         ( -- )
                  s" 5,9" s" WindowPosition" SetSetting ;
! 
--- 231,233 ----
  : test!         ( -- )
                  s" 5,9" s" WindowPosition" SetSetting ;
! 

[Win32forth-cvs] win32forth-610old/htm p-relnotes.6.10.htm,1.1,1.2

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-610old/htm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9828/win32forth-610old/htm

Modified Files:
	p-relnotes.6.10.htm 
Log Message:
gah:  fixed links to sciedit and project manager docs

Index: p-relnotes.6.10.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth-610old/htm/p-relnotes.6.10.htm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** p-relnotes.6.10.htm	22 May 2005 09:48:12 -0000	1.1
--- p-relnotes.6.10.htm	24 May 2005 07:55:14 -0000	1.2
***************
*** 142,147 ****
  <h2>New Applications</h2>
  <ul>
!   <li><a href="SciEdit/SciEdit.htm">SciEdit</a> (Win32Forth Source-Editor)</li>
!   <li><a href="ProMgr/ProjectManager.htm">ForthProject</a> (Win32Forth Project Manager)</li>
  </ul>
  
--- 142,147 ----
  <h2>New Applications</h2>
  <ul>
!   <li><a href="SciEdit.htm">SciEdit</a> (Win32Forth Source-Editor)</li>
!   <li><a href="ProjectManager.htm">ForthProject</a> (Win32Forth Project Manager)</li>
  </ul>
  

[Win32forth-cvs] win32forth/src FLOAT.F,1.6,1.7

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9516/win32forth/src

Modified Files:
	FLOAT.F 
Log Message:
gah:  optimized multiplication by b/float for stack checking

Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** FLOAT.F	19 May 2005 08:13:27 -0000	1.6
--- FLOAT.F	24 May 2005 07:53:16 -0000	1.7
***************
*** 225,233 ****
  \ Input: eax = number of floats we need
  subr:   fstack-check 
!                 push    edx
!                 mov     edx, # B/FLOAT
!                 mul     eax, edx
!                 pop     edx
!                 mov     ecx, FSP_MEMORY
                  sub     ecx, eax
                  js      short L$1
--- 225,234 ----
  \ Input: eax = number of floats we need
  subr:   fstack-check 
!                 
! B/FLOAT 10 = [IF]
!                 lea eax, 0 [eax*4] [eax] 
!                 add eax, eax
!          [ELSE] shl eax, # 3
!          [THEN] mov     ecx, FSP_MEMORY
                  sub     ecx, eax
                  js      short L$1

[Win32forth-cvs] win32forth/apps/PlayVirginRadio PlayVirginRadio.f,NONE,1.1 Virgin.ico,NONE,1.1

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/PlayVirginRadio
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12115/apps/PlayVirginRadio

Added Files:
	PlayVirginRadio.f Virgin.ico 
Log Message:
New application "PlayVirginRadio" added

--- NEW FILE: PlayVirginRadio.f ---
\    File: PlayVirginRadio.f
\
\  Authors: Dirk Busch      di...@wi...
\
\ Created: Montag, Mai 16 2005 - dbu
\ Updated: Montag, Mai 16 2005 - dbu
\
\ Simple application that play's "Virgin Radio" from the net
\ The w32fHtmlDisplay.dll is nedded.

cr .( Loading Player 4th...)

anew -PlayVirginRadio.f

needs struct.f
needs apps\Player4\TrayWindow.f
needs HtmlDisplayControl.f

true  value turnkey?
\ false value turnkey?

0 value _CurrentPopup

\ -----------------------------------------------------------------------------
\       Define the Main Window
\ -----------------------------------------------------------------------------
:Object MainWindow  <super TrayWindow

HtmlDisplayControl Player

:M WindowTitle: ( -- Zstring ) \ window caption
        z" Virgin Radio Player" ;M

:M WindowStyle: ( -- n )
        [ WS_OVERLAPPED WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MINIMIZEBOX or ] literal
        ;M
        
:M StartSize:   ( -- w h )
        470 265 ;M

:M On_Size:     ( -- )
        On_Size: super
        AutoSize: Player
        ;M

:M WM_CLOSE     ( h m w l -- res )
        Stop: Player
        DestroyWindow: Player

        WM_CLOSE WM: Super
        bye 0 ;M

:M ShowWindow:  ( -- )
        IsVisible?: self 0=
        if   ShowWindow: super
        then ;M

:M HideWindow:  ( -- )
        IsVisible?: self
        if   HideWindow: super
        then ;M

:M GetTooltip:  ( -- addr len )
        WindowTitle: self zcount ;M

:M Play:        ( -- )
        z" http://www.smgradio.com/core/player/index.html?service=vc"
        SetURL: Player ;M

:M Pause:       ( -- )
        Stop: Player ;M

:M Resume:      ( -- )
        Refresh:  Player ;M

:M On_Init:     ( -- )
        On_Init: super
        1001 SetId: Player
        self Start: Player
        ;M

:M DefaultIcon: ( -- hIcon )            \ return the default icon handle for window
        s" Virgin.ico" LoadIconFile
        ;M

;Object


\ -----------------------------------------------------------------------------
\ Turn the sound on and off
\ -----------------------------------------------------------------------------
WinLibrary winmm.dll

: (volume!)     ( left-sound-volume right-sound-volume  -- )
        depth 2 >=
        if 0max 99 min 65535 100 */ 65536 * swap
           0max 99 min 65535 100 */ +
           0 Call waveOutSetVolume drop
        else cr ." No enough parameters !!! "
        then ;

: volume!       ( sound-volume -- )
        dup (volume!) ;

100 value volume

: SoundOn       ( -- )
        100 dup to volume volume! ;

: SoundOff      ( -- )
        0 dup to volume volume! ;

: SoundOnOff    ( -- )
        volume 0=
        if   SoundOn
        else SoundOff
        then ;

\ -----------------------------------------------------------------------------
\       Define the Popup bar
\ -----------------------------------------------------------------------------
\ POPUPBAR player-popup-bar
\     POPUP " "
\         MENUITEM     "&Sound on/off"    SoundOnOff ;
\         MENUSEPARATOR
\         MENUITEM     "&Exit\tAlt+F4"    DestroyWindow: MainWindow ;
\ ENDBAR

\ -----------------------------------------------------------------------------
\ -----------------------------------------------------------------------------
: uninit-player ( -- )
        DestroyWindow: MainWindow
        ExitHtmlControl
        SoundOn ;
unload-chain chain-add-before uninit-player

\ -----------------------------------------------------------------------------
\ -----------------------------------------------------------------------------
: InitPlayer    ( -- )
        InitHtmlControl \ must be called once at startup
        Start: MainWindow
        Play: MainWindow \ start playing radio...
        HideWindow: MainWindow \ hide the window in the traybar
\         player-popup-bar SetPopupBar: MainWindow
        ;

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Turnkey without needing w32fConsole.dll \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Create MessageStructure 32 allot
: MessageLoop ( -- )   \ instead of "Begin key drop again"
        BEGIN  0 0 0 MessageStructure Call GetMessage
        WHILE  MessageStructure HandleMessages drop
        REPEAT
        ;

: NoConsole ( -- )
        initialization-chain do-chain 
        default-application ;
' NoConsole is default-hello


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ The application \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: go ( -- )
        InitPlayer
        Turnkeyed?
        IF   MessageLoop bye
        THEN ;

turnkey? [if]

        \ Tell Imageman that we don't need the w32fconsole.dll
        \ if possible (in older w32f versions you have to modify
        \ Imageman.f to do this).
        also VIMAGE
[defined] CONSOLE-DLL? [if]
        false to CONSOLE-DLL?
[then]

        \ Tell Imageman that we don't need the w32fHtmlDisplay.dll
        \ if possible (in older w32f versions you have to modify
        \ Imageman.f to do this).
[defined] HTML-DISPLAY-DLL? [if]
        true to HTML-DISPLAY-DLL?
[then]
        ' go turnkey PlayVirginRadio.exe
        5 pause-seconds
[else]
        go
[then]

[Win32forth-cvs] win32forth/apps/PlayVirginRadio - New directory

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/PlayVirginRadio
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11985/PlayVirginRadio

Log Message:
Directory /cvsroot/win32forth/win32forth/apps/PlayVirginRadio added to the repository