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 ;
+
|
