win32forth-cvs

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

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13237/win32forth-stc/src

Modified Files:
	Class.f primutil.f 
Log Message:
gah:Added some of the gdi functions updated primutil.f with extra utilities needed for GUI and bugfixes/extensions to class.f

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -d -r1.26 -r1.27
*** primutil.f	24 Apr 2007 09:13:14 -0000	1.26
--- primutil.f	28 Apr 2007 10:18:56 -0000	1.27
***************
*** 54,57 ****
--- 54,58 ----
  : dbg ' execute                 ; immediate     \ *** to be done ***
  : ?COMP                         ; immediate     \ *** to be done ***
+ ' drop alias ?win-error
  
  \ ------------------------------------------------------------------------
***************
*** 138,141 ****
--- 139,154 ----
                  swap t|Cl = or ;
  
+ defer \n->crlf
+ 
+ : _\n->crlf     ( a1 n1 -- )    \ parse "\n" occurances, change to CRLF's
+                 begin   [char] \ scan dup               \ found a '\' char
+                 while   over 1+ c@ [char] n =           \ followed by 'n'
+                         if      over 13 swap c!         \ replace with CR
+                                 over 10 swap 1+ c!      \ replace with LF
+                         then    1 /string               \ else skip '\' char
+                 repeat  2drop   ;
+ 
+ ' _\n->crlf is \n->crlf                 \ link into kernel deferred word
+ 
  \ Moved to user area to make asciiz thread safe gah 28jun04
  MAXSTRING newuser z-buf
***************
*** 283,286 ****
--- 296,330 ----
  
  \ ------------------------------------------------------------------------
+ \       Needed by dialogs and menus
+ \ ------------------------------------------------------------------------
+ 
+ \ ,"TEXT" also detect \T embeded in the text and replaces it with a TAB char
+ \ Note: ,"TEXT" is partly brocken. It only detects and replaces the first \T
+ \ in the text all other \T's will not be changed.
+ : ,"TEXT"       ( -<"text">- )  \ parse out quote delimited text and compile
+                                 \ it at here  NO EXTRA SPACES ARE NEEDED !!!
+                 source >in @ /string
+                 [char] " scan 1 /string                 \ skip past first quote
+                 2dup [char] " scan                      \ upto next quote
+                 2dup 2>r nip -                          \ parse out the string
+                 "CLIP" dup>r
+                 2dup \n->crlf                           \ fix newlines
+                 2dup [char] \ scan 2dup 2>r nip -       \ leading part of string
+                 here place                              \ save in BNAME
+                 2r>
+                 -IF     over 1+ c@ upc [char] T =
+                         IF      9         here c+place
+                                 2 /string here  +place
+                                 r> 1- >r
+                         ELSE    here +place
+                         THEN
+                 ELSE    2drop
+                 THEN
+                 r> 1+ allot
+                 0 c,                            \ null terminate name
+                 source nip 2r> 1 /string nip - >in !    \ adjust >IN
+                 ;
+ 
+ \ ------------------------------------------------------------------------
  \       Often used
  \ ------------------------------------------------------------------------

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/Class.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Class.f	25 Apr 2007 09:41:53 -0000	1.2
--- Class.f	28 Apr 2007 10:18:56 -0000	1.3
***************
*** 252,255 ****
--- 252,269 ----
  in-system
  
+ \ Temporary fix for ?isLocal to work
+ tloc ' local0  >name n>tfa c!
+ tloc ' local1  >name n>tfa c!
+ tloc ' local2  >name n>tfa c!
+ tloc ' local3  >name n>tfa c!
+ tloc ' local4  >name n>tfa c!
+ tloc ' local5  >name n>tfa c!
+ tloc ' local6  >name n>tfa c!
+ tloc ' local7  >name n>tfa c!
+ tloc ' local8  >name n>tfa c!
+ tloc ' local9  >name n>tfa c!
+ tloc ' local10 >name n>tfa c!
+ tloc ' local11 >name n>tfa c!
+ 
  : [self]        ( -- )
                  true abort" Use only for self-reference to object" ; immediate
***************
*** 259,264 ****
--- 273,280 ----
  : ?isValue      ( cfa -- f )
                  >name n>tfa c@ tVal = ;
+ 
  : ?isLocal      ( cfa -- f )
                  >name n>tfa c@ tLoc = ;
+ 
  : ?isVect       ( cfa -- f )
                  >name n>tfa c@ dup tVal =
***************
*** 412,416 ****
                  dup>r IDX-HDR reserve   \ allot space for indexed data
                  r> IFA @ 0 ITRAV        \ init instance variables
!                 ( ClassInit ) ;             \ send CLASSINIT: message
  
  : (|Build)      ( #elems ^class OR ^class -- )  \ Build an instance of a class
--- 428,432 ----
                  dup>r IDX-HDR reserve   \ allot space for indexed data
                  r> IFA @ 0 ITRAV        \ init instance variables
!                 ClassInit  ;             \ send CLASSINIT: message
  
  : (|Build)      ( #elems ^class OR ^class -- )  \ Build an instance of a class
***************
*** 788,792 ****
                  THEN
                  State @
!                 IF      POSTPONE (Defer)  R> ,
                  ELSE    R> swap Find-Method execute
                  THEN    ;
--- 804,808 ----
                  THEN
                  State @
!                 IF      r> postpone literal POSTPONE (Defer)
                  ELSE    R> swap Find-Method execute
                  THEN    ;
***************
*** 1116,1130 ****
  \ -------------------- Instance Variables --------------------
  
! ((
  : byte          ( -<name>- )           \ W32F          Class
  \ *G Byte (8bit) size instance variable.
!                 header
!                 (ivc@) ,
!                 ^Class DFA @ ,
!                 (ivc!) ,
!                 (ivc+!) ,
!                 8 bitmax                \ verify & set bit field finished & new max
!                 1 class-allot ;
  
  in-previous
  
--- 1132,1156 ----
  \ -------------------- Instance Variables --------------------
  
! 20 constant TByte
! 
! : DoByte
!                 does> @ self + C@ ;
! 
  : byte          ( -<name>- )           \ W32F          Class
  \ *G Byte (8bit) size instance variable.
! \                 header
! \                 (ivc@) ,
! \                 ^Class DFA @ ,
! \                 (ivc!) ,
! \                 (ivc+!) ,
! \                 8 bitmax                \ verify & set bit field finished & new max
! \                 1 class-allot ;
!                 Create ^Class dfa @ ,
!                 1 class-allot
!                 DoByte
!                 tByte tfa! ;
! 
  
+ ((
  in-previous
  
***************
*** 1239,1245 ****
  : (classto)     ( n -<value>- -- )
                  >in @ ^class if bl word count ^class (search-self)
!                 ?dup if  dup n>tfa c@ tint = if name>xt nip nip
                  >body @ postpone ^base postpone literal postpone + postpone !
!                 exit else drop then then then >in ! oldto ;
  
  ' (classto) compiles-for to
--- 1265,1273 ----
  : (classto)     ( n -<value>- -- )
                  >in @ ^class if bl word count ^class (search-self)
!                 ?dup if  dup n>tfa c@ dup tint = if drop name>xt nip nip
                  >body @ postpone ^base postpone literal postpone + postpone !
!                 exit then tbyte = if name>xt nip nip
!                 >body @ postpone ^base postpone literal postpone + postpone c!
!                 exit then drop then then >in ! oldto ;
  
  ' (classto) compiles-for to
***************
*** 1251,1255 ****
                  ?dup if  dup n>tfa c@ tint = if name>xt nip nip
                  >body @ postpone ^base postpone literal postpone + postpone +!
!                 exit else drop then then then >in ! old+to ;
  
  ' (class+to) compiles-for +to
--- 1279,1283 ----
                  ?dup if  dup n>tfa c@ tint = if name>xt nip nip
                  >body @ postpone ^base postpone literal postpone + postpone +!
!                 exit then drop then then >in ! old+to ;
  
  ' (class+to) compiles-for +to