[Win32forth-cvs] win32forth-stc/src primutil.f,1.2,1.3

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

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

Modified Files:
	primutil.f 
Log Message:
gah: Merged some words needed for loading ansfile.f (use ITC version) (untesteed til mon 25/9/6) to try out uncomment out the \\S

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** primutil.f	23 Sep 2006 10:18:34 -0000	1.2
--- primutil.f	23 Sep 2006 15:49:12 -0000	1.3
***************
*** 14,17 ****
--- 14,18 ----
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
  \                       Dirk Busch    (dirk.yahoo @ schneider-busch.de)
+ \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
  \ This program is free software; you can redistribute it and/or modify it
***************
*** 45,48 ****
--- 46,53 ----
  : ANEW          BL WORD DROP    ; immediate     \ *** to be done ***
  : IS-DEFAULT    BL WORD 2DROP   ; immediate     \ *** to be done ***
+ : DPR-WARNING-ON                ; immediate     \ *** to be done ***
+ : DPR-WARNING-OFF               ; immediate     \ *** to be done ***
+ 0 value DPR-WARNING?            \ null value      *** to be done ***
+ : CHECKSTACK                    ; immediate     \ *** to be done ***
  
  \ ------------------------------------------------------------------------
***************
*** 94,103 ****
  \ ------------------------------------------------------------------------
  
! ' included alias "fload
! ' fload    alias include
! ' requires alias needs
! ' dpl      alias dp-location
  
! ' postpone alias compile
  
  defer enter-assembler ' noop is enter-assembler
--- 99,110 ----
  \ ------------------------------------------------------------------------
  
! ' included  alias "fload
! ' fload     alias include
! ' requires  alias needs
! ' dpl       alias dp-location
  
! ' postpone  alias compile
! 
! ' maxbuffer alias max-path
  
  defer enter-assembler ' noop is enter-assembler
***************
*** 192,193 ****
--- 199,250 ----
                  ['] interpret catch
                  r> to sys-warning? throw ; immediate
+ 
+ \s
+ \ needed by ansfile; uncomment \s to load ansfile (I tested it at home with my own
+ \ primutil.f and hopefully merged everything correctly but can't test @ work so any
+ \ other corrections will have to wait til mon 23/9/6 gah.
+ 
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ \       Some case insensitive version of search and compare
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ 
+ \ enhanced caps-search for source string > 255 bytes
+ \ search for t-adr,t-len within string s-adr,s-len. f1=true if string was found
+ : CAPS-SEARCH  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
+ \ *G Search the string specified by c-addr1 u1 for the string specified by c-addr2 u2,
+ \ ** using a case-insensitive search. \n
+ \ ** If flag is true, a match was found at c-addr3 with u3 characters remaining. \n
+ \ ** If flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
+         { s-adr s-len t-adr t-len \ t-buf t-str -- adr len flag }
+         MAXSTRING localalloc: t-str
+         s-len cell+ ALLOCATE 0=
+         IF      to t-buf                    \ make a buffer big enough for s-adr
+                 t-adr t-len t-str place
+                 t-str count upper
+                 s-adr t-buf s-len move
+                 t-buf s-len upper
+                 t-buf s-len t-str count search
+                 IF      nip                     \ discard found address
+                         s-len swap -            \ offset where string was found
+                         s-adr s-len rot /string
+                                       \ location of found string in original buf
+                         TRUE
+                 ELSE    2drop
+                         s-adr s-len FALSE
+                 THEN
+                 t-buf FREE drop
+         ELSE    s-adr s-len FALSE             \ failed, couldn't allocate buffer
+         THEN    ;
+ 
+ \ COMPARE compares two strings, ignoring case. The return value is:
+ \
+ \        0 = string1 = string2
+ \       -1 = string1 < string2
+ \        1 = string1 > string2
+ : CAPS-COMPARE  { sa1 sn1 sa2 sn2 \ st1 st2 -- f1 }
+                 MAXSTRING LocalAlloc: st1
+                 MAXSTRING LocalAlloc: st2
+                 sa1 sn1 st1 place  st1 count upper
+                 sa2 sn2 st2 place  st2 count upper
+                 st1 count st2 count compare ;
+