Thread: [Win32forth-cvs] win32forth/src ANSFILE.F, 1.4, 1.5 GENERIC.F, 1.13, 1.14 POINTER.F, 1.8, 1.9 Primu

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

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

Modified Files:
	ANSFILE.F GENERIC.F POINTER.F Primutil.f SEE.F paths.f 
Log Message:
gah:Made GETTEXT$ in GENERIC.F thread-safe, added code to see pointers and minor mods

Index: ANSFILE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/ANSFILE.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** ANSFILE.F	13 Mar 2006 14:16:51 -0000	1.4
--- ANSFILE.F	11 Aug 2006 10:09:45 -0000	1.5
***************
*** 142,147 ****
     5 (DOSTime) ;

- module
- 
  : get-file-size ( -- size )
  \ need to call find-first-file or find-next-file word
--- 142,145 ----
***************
*** 155,159 ****

  2 cells newuser file-time-buf
! 

  : get-file-modified ( fileid -- system-time )
--- 153,158 ----

  2 cells newuser file-time-buf
! \ *G 2Variable to hold the FILETIME structure, which is a little endian (i.e. reversed order)
! \ ** 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601.

  : get-file-modified ( fileid -- system-time )
***************
*** 287,288 ****
--- 286,290 ----
  IN-APPLICATION

+ module
+ 
+ \ *Z

Index: GENERIC.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/GENERIC.F,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** GENERIC.F	11 Jun 2006 07:37:27 -0000	1.13
--- GENERIC.F	11 Aug 2006 10:09:45 -0000	1.14
***************
*** 269,273 ****
                  then ;M

! named-new$ gettext$

  :M GetText:     ( -- addr len )
--- 269,273 ----
                  then ;M

! maxstring newuser gettext$

  :M GetText:     ( -- addr len )

Index: paths.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/paths.f,v
retrieving revision 1.23
retrieving revision 1.24
diff -C2 -d -r1.23 -r1.24
*** paths.f	5 Aug 2006 12:27:39 -0000	1.23
--- paths.f	11 Aug 2006 10:09:45 -0000	1.24
***************
*** 287,291 ****

  : FindRelativeName  ( a1 n1 path-ptr - a2 n2 f )
! \ *G Returns a releative name for file a1 n1 in path-ptr ( last-part ). \n
  \ ** n2=0 means not in search path.
          >r 2dup r> FindRelativePath dup 0>
--- 287,291 ----

  : FindRelativeName  ( a1 n1 path-ptr - a2 n2 f )
! \ *G Returns a relative name for file a1 n1 in path-ptr ( last-part ). \n
  \ ** n2=0 means not in search path.
          >r 2dup r> FindRelativePath dup 0>
***************
*** 313,317 ****

  : "LOADED?      ( addr len -- flag )
! \ *G True if a file addr len is loaded. The filename must cointain a full path.
                  CONTEXT @ >R               \ save context
                  files                      \ set context
--- 313,317 ----

  : "LOADED?      ( addr len -- flag )
! \ *G True if a file addr len is loaded. The filename must contain a full path.
                  CONTEXT @ >R               \ save context
                  files                      \ set context
***************
*** 333,357 ****
  : \LOADED-      ( -<name>- )
  \ *G If the following file IS NOT LOADED interpret line.
!                 >in @ >r
!                 loaded? 0=
!                 if      interpret
!                 else    postpone \
!                 then    r>drop ;

  : \LOADED       ( -<name>- )
  \ *G  If the following file IS LOADED interpret line.
!                 >in @ >r
!                 loaded?
!                 if      interpret
!                 else    postpone \
!                 then    r>drop ;

  : NEEDS         ( -<name>- )
  \ *G Conditionally load file "name" if not loaded.
!                 >in @ >r
!                 loaded? 0=                     \ if file isn't loaded
!                 if      r@ >in !
!                         fload                   \ then loadit
!                 then    r>drop ;

  synonym Require needs
--- 333,345 ----
  : \LOADED-      ( -<name>- )
  \ *G If the following file IS NOT LOADED interpret line.
!                 loaded? if postpone \ then ;

  : \LOADED       ( -<name>- )
  \ *G  If the following file IS LOADED interpret line.
!                 loaded? 0= if postpone \ then ;

  : NEEDS         ( -<name>- )
  \ *G Conditionally load file "name" if not loaded.
!                 >in @ loaded? 0= if >in ! fload else drop then ;

  synonym Require needs

Index: POINTER.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/POINTER.F,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** POINTER.F	8 Aug 2006 14:09:08 -0000	1.8
--- POINTER.F	11 Aug 2006 10:09:45 -0000	1.9
***************
*** 5,13 ****
  cr .( Loading Memory Pointer...)

! \ BODY          +0             +4      +8            +12
! \               [ phy_pointer ][ link ][ size_bytes ][ ptr->link ]

  in-application

  VARIABLE PHEAD  PHEAD OFF

--- 5,15 ----
  cr .( Loading Memory Pointer...)

! \ BODY          +0             +4      +8              |    +12 ( removed)
! \               [ phy_pointer ][ link ][ size_bytes ]  | [ ptr->link ]

  in-application

+ internal
+ 
  VARIABLE PHEAD  PHEAD OFF

***************
*** 20,23 ****
--- 22,35 ----
  initialization-chain chain-add pointers-init

+ cfa-func DoPointer  ( -- address )                  \ it's location
+                 dup @ if @ exit then                  \ ok, straight fetch
+                 dup (pointerlock)
+                 @ if (pointerunlock) @ exit then  \ another task won the race
+                 dup 2 cells+ @ allocate 0=
+                 if     dup off                 \ set first cell to zeros
+                        tuck swap ! (pointerunlock) exit
+                 then   (pointerunlock) 1-
+                        abort" Failed to allocate POINTER" ;
+ 
  in-system

***************
*** 34,63 ****
  forget-chain chain-add trim-pointers

! :NONAME         ( link -- )                      \ .POINTERS
!                 DUP CELL- BODY> >R
!                 CR DUP CELL+ @ 10 U,.R ."  bytes at: "
!                 CELL- @ ?DUP
                  IF      13 H.R
                  ELSE    ." <unallocated>"
!                 THEN    ."  for: " R> .NAME
                  ; : .POINTERS ( -- )
                      LITERAL [ !CSP ]             \ make sure CSP is adjusted
                      PHEAD DO-LINK ;              \ from noname above

! in-application

! : ?VALID_POINTER ( plink -- plink )     \ check for valid pointer sturcture
!                  TURNKEYED? ?EXIT       \ no point if this is turnkeyed
!                  DUP 2 cells+ @ OVER <>
!                  IF      cell - BODY> DUP CR h.
! \IN-SYSTEM-OK            .name
                           ." is NOT a valid POINTER structure!"
                           ABORT
                   THEN    ;

  : %UnPointer    ( cfa -- )      \ deallocate pointer given the cfa
!                 >BODY DUP @ 0<>                  \ only if non-zero (added missing 0<> February 6th, 2004 - 18:35 dbu)
!                 IF      DUP cell+ ?VALID_POINTER DROP
!                         DUP @ release            \ release the memory
                          off                      \ clear the memory pointer
                  ELSE DROP
--- 46,87 ----
  forget-chain chain-add trim-pointers

! : (.Pointer)    ( pfa -- )
!                 dup 2 cells+ @ 10 U,.R ."  bytes at: "
!                 @ ?DUP
                  IF      13 H.R
                  ELSE    ." <unallocated>"
!                 THEN     ;
! 
! : .Pointer      ( cfa -- )
!                 ." POINTER " dup .name >body (.Pointer) ;
! 
! external
! 
! :NONAME         ( link -- )                      \ .POINTERS
!                 cr CELL-  dup>r (.Pointer) ."  for: " R> body> .NAME
                  ; : .POINTERS ( -- )
                      LITERAL [ !CSP ]             \ make sure CSP is adjusted
                      PHEAD DO-LINK ;              \ from noname above

! internal

! : (IsPointer?)   ( plink -- plink )     \ check for valid pointer structure
!                  DUP @ Dopointer <>
!                  IF      DUP CR h.
!                          .name
                           ." is NOT a valid POINTER structure!"
                           ABORT
                   THEN    ;

+ in-application
+ 
+ : IsPointer?    ( cfa -- cfa )                    \ check for valid pointer structure
+ \in-system-ok     TURNKEYED? ?EXIT (IsPointer?) ; \ no point if this is turnkeyed
+ 
+ external
+ 
  : %UnPointer    ( cfa -- )      \ deallocate pointer given the cfa
!                 IsPointer? >BODY DUP @ 0<>                  \ only if non-zero (added missing 0<> February 6th, 2004 - 18:35 dbu)
!                 IF      DUP @ release            \ release the memory
                          off                      \ clear the memory pointer
                  ELSE DROP
***************
*** 65,69 ****

  : >POINTER      ( cfa -- ptr )      \ move to ptr
!                 >BODY cell+ ?VALID_POINTER cell+ ;

  : %SizeOf!      ( bytes cfa -- )    \ set the size of pointer "cfa"
--- 89,93 ----

  : >POINTER      ( cfa -- ptr )      \ move to ptr
!                 IsPointer? >BODY 2 cells+ ;

  : %SizeOf!      ( bytes cfa -- )    \ set the size of pointer "cfa"
***************
*** 88,101 ****
                  then    (pointerunlock) ;

- : DOES>Pointer  ( -- address )                  \ it's location
-                 DOES>
-                 dup @ if @ exit then                  \ ok, straight fetch
-                 dup (pointerlock)
-                 @ if (pointerunlock) @ exit then  \ another task won the race
-                 dup 2 cells+ @ allocate 0=
-                 if     dup off                 \ set first cell to zeros
-                        tuck swap ! (pointerunlock) exit
-                 then   (pointerunlock) 1-
-                        abort" Failed to allocate POINTER" ;

  in-system
--- 112,115 ----
***************
*** 104,112 ****
                  >APPLICATION                    \ always in app space
                  128 max                         \ at least 160 bytes
!                 CREATE 0 ,                      \ initialize to unallocated
                  HERE  PHEAD @ ,  PHEAD !        \ link into chain
                  ,                               \ lay in size in bytes
-                 PHEAD @ ,                       \ POINTER CHAIN verify word
-                 DOES>Pointer
                  APPLICATION> ;                  \ back to where we came from

--- 118,124 ----
                  >APPLICATION                    \ always in app space
                  128 max                         \ at least 160 bytes
!                 header DoPointer compile, 0 ,   \ initialize to unallocated
                  HERE  PHEAD @ ,  PHEAD !        \ link into chain
                  ,                               \ lay in size in bytes
                  APPLICATION> ;                  \ back to where we came from

***************
*** 169,170 ****
--- 181,186 ----
  initialization-chain chain-add init-new$

+ module
+ 
+ \ *Z
+ 

Index: SEE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/SEE.F,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** SEE.F	3 Aug 2006 13:08:22 -0000	1.7
--- SEE.F	11 Aug 2006 10:09:45 -0000	1.8
***************
*** 291,294 ****
--- 291,295 ----
              dovoc       of .vocabulary  endof
              doObj       of .object      endof
+             doPointer   of .pointer     endof
          swap .other
      endcase ;

Index: Primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** Primutil.f	5 Aug 2006 12:30:52 -0000	1.16
--- Primutil.f	11 Aug 2006 10:09:45 -0000	1.17
***************
*** 118,122 ****
  \ September 16th, 2003 - 10:27 dbu
  : cfa-func      ( -<name>- )
!                 header docon compile, code-here , hide !csp dodoes-call, ] ;

  defer enter-assembler ' noop is enter-assembler
--- 118,122 ----
  \ September 16th, 2003 - 10:27 dbu
  : cfa-func      ( -<name>- )
!                 header docon compile, ( code-here , ) hide !csp dodoes-call, ] ;

  defer enter-assembler ' noop is enter-assembler

Thread: [Win32forth-cvs] win32forth/src ANSFILE.F, 1.4, 1.5 GENERIC.F, 1.13, 1.14 POINTER.F, 1.8, 1.9 Primu

win32forth-cvs