home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
rbsrc
/
rb-eflt.scr
< prev
next >
Wrap
Text File
|
1988-05-09
|
20KB
|
1 lines
\ Build 14:06 03/23/88 : MARKER ; 2 LOAD 2 LOAD BSAVE OVERLAY RBEFILT FORGET MARKER BYE \ Variables 09:53 03/22/88 FORTH DEFINITIONS DECIMAL BSTART OVERLAY 7 5 04 20 WINDOW CHOICEW 5 10 15 62 WINDOW FILTERW INCLUDE FIELD.DEF HCB FLT.FIL : <#NC#> ( d #decs --- addr count ) -ROT <# 32 HOLD ROT ?DUP IF 0 ?DO # LOOP 46 HOLD THEN #S #> ; --> \ filter 11:22 03/22/88 INCLUDE FILTER.DEF 0 EQU FLT.BUFF 0 EQU DUMMY CREATE INP.PAD 40 ALLOT : 'FLT.BUFF ( 0-14 --- addr ) SIZEOF FILTER * FLT.BUFF + ; : CHSTR " Edit conditions Apply filter Remove filter " ; --> \ formators 10:45 03/23/88 : FTEXT FLT.HOLD INP.PAD 2+ 38 CMOVE ; : FNUM FLT.HOLD 2@ FLD.BUFF FLD.MS/LS @ 256 /MOD DROP <#NC#> INP.PAD 2+ SWAP CMOVE ; : FDATE FLT.HOLD 2@ SWAP 100 /MOD DROP SWAP 256 /MOD 100 * + 100 UM* ROT 0 D+ <# # # 47 HOLD # # 47 HOLD # # #> INP.PAD 2+ SWAP CMOVE ; : FYES/NO FLT.HOLD C@ 3 * " No Yes" 1+ + INP.PAD 2+ 3 CMOVE ; --> \ expand-filter 13:51 03/22/88 CREATE TCHG 0 C, 1 C, 1 C, 3 C, 4 C, 0 C, 6 C, 0 C, 0 C, : EXPAND-FILTER ( 1-14 --- ) INP.PAD 40 BLANK 'FLT.BUFF DUP FLT.OPER C@ 60 + INP.PAD 1+ C! DUP FLT.TYPE C@ TCHG + C@ CASE 0 OF FTEXT ENDOF 1 OF FNUM ENDOF 4 OF FDATE ENDOF 6 OF FYES/NO ENDOF 3 OF FTEXT ENDOF NIP ENDCASE ; --> \ ?cond 15:00 03/22/88 : ?COND ( --- 0-14 for buffer, -1 for not here ) -1 15 0 DO I 'FLT.BUFF FLT.OFFSET @ FLD.BUFF FLD.OFFSET @ = IF DROP I LEAVE THEN LOOP ; --> \ new.fmt 11:13 03/22/88 : NEW.FMT ( cb --- len addr ) DROP ?COND DUP -1 <> IF EXPAND-FILTER ELSE DROP INP.PAD 40 BLANK THEN FLD.BUFF FLD.NAME 20 INP.PAD 40 STRCAT DROP 179 OVER 20 + C! 60 SWAP ; --> \ nxt-flt 09:26 03/23/88 : NXT-FLT ( --- -1 for none, 0-14 ) -1 15 0 DO I 'FLT.BUFF FLT.OFFSET @ 0 = IF DROP I LEAVE THEN LOOP ; --> \ oks 15:13 03/22/88 : OK-NUM ( cond -- T/F ) INP.PAD 2+ DUP 38 32 SCAN DROP OVER - STRPCK NUMBER? DROP FLD.BUFF FLD.MS/LS @ 256 /MOD DROP DPL @ DUP -1 = IF NOT THEN - 0 ?DO 10D* LOOP ?COND DUP -1 = IF DROP NXT-FLT THEN DUP -1 = IF 4DROP 0 EXIT THEN 'FLT.BUFF DUP >R FLT.TYPE 1 SWAP C! R@ FLT.HOLD 2! R@ FLT.OPER C! FLD.BUFF FLD.OFFSET @ R> FLT.OFFSET ! -1 ; --> \ ok-text 09:33 03/23/88 : OK-TEXT ( cond --- t/f ) ?COND DUP -1 = IF DROP NXT-FLT THEN DUP -1 = IF 2DROP 0 EXIT THEN 'FLT.BUFF DUP >R FLT.TYPE 0 SWAP C! R@ FLT.HOLD 40 BLANK R@ FLT.OPER C! 38 FLD.BUFF FLD.LENGTH @ MIN R@ FLT.SIZE ! INP.PAD 2+ R@ FLT.HOLD R@ FLT.SIZE @ CMOVE FLD.BUFF FLD.OFFSET @ R> FLT.OFFSET ! -1 ; --> \ ok-date 10:21 03/23/88 : PDATE ( cstr --- d ) DUP NUMBER? 2DROP SWAP COUNT DROP 3 ASCII / SCAN DROP 1+ DUP 2 STRPCK NUMBER? 2DROP SWAP 5 ASCII / SCAN DROP 1+ 2 STRPCK NUMBER? 2DROP 1900 + ROT 256 * ROT + ; : OK-DATE ( oper --- t/f ) ?COND DUP -1 = IF DROP NXT-FLT THEN DUP -1 = IF 2DROP 0 EXIT THEN 'FLT.BUFF >R INP.PAD 2+ 38 STRPCK PDATE R@ FLT.HOLD 2! FLD.BUFF FLD.OFFSET @ R@ FLT.OFFSET ! R@ FLT.OPER C! 4 R> FLT.TYPE C! -1 ; --> --> \ ok-yes/no 10:54 03/23/88 : OK-YES/NO ( oper --- t/f ) ?COND DUP -1 = IF DROP NXT-FLT THEN DUP -1 = IF 2DROP 0 EXIT THEN 'FLT.BUFF >R INP.PAD 2+ 38 MAKEUC INP.PAD 2+ 38 ASCII Y SCAN NIP 0 = IF 0 ELSE 1 THEN R@ FLT.HOLD C! R@ FLT.OPER C! 6 R@ FLT.TYPE C! FLD.BUFF FLD.OFFSET @ R> FLT.OFFSET ! -1 ; --> \ ok-relat 09:33 03/23/88 : OK-RELAT ( cond --- t/f ) ?COND DUP -1 = IF DROP NXT-FLT THEN DUP -1 = IF 2DROP 0 EXIT THEN 'FLT.BUFF DUP >R FLT.TYPE 3 SWAP C! R@ FLT.HOLD 40 BLANK R@ FLT.OPER C! 38 R@ FLT.SIZE ! INP.PAD 2+ R@ FLT.HOLD 38 CMOVE FLD.BUFF FLD.OFFSET @ R@ FLT.OFFSET ! FLD.BUFF FLD.FIELD @ R@ FLT.RFLD# ! FLD.BUFF FLD.RELATION @ R> FLT.RFILE# ! -1 ; --> \ ok-term? 14:30 03/22/88 : OK-TERM? INP.PAD 1+ C@ DUP 62 60 ISSET SWAP 32 = OR 0= IF 0 ERRTONE EXIT THEN INP.PAD 1+ C@ DUP 32 = IF DROP ?COND DUP -1 <> IF 'FLT.BUFF 46 ERASE 0 THEN DROP -1 EXIT THEN 60 - FLD.BUFF FLD.TYPE C@ TCHG + C@ CASE 0 OF OK-TEXT DROP ENDOF 1 OF OK-NUM DROP ENDOF 3 OF OK-RELAT DROP ENDOF 4 OF OK-DATE DROP ENDOF 6 OF OK-YES/NO DROP ENDOF NIP ENDCASE -1 ; --> \ new.inp 11:14 03/22/88 : NEW.INP 0 BEGIN DROP 2 PICK OVER 23 SWAP ROT INP.PAD 1+ 39 @STRING OK-TERM? UNTIL DUP 59 = IF 2 HELP 1 THEN DUP 13 = IF DROP 80 THEN DUP 68 = IF DROP 13 THEN ; --> ' NEW.INP ' NEW.FMT ' NO.COND ' NOOP FLD.BUFF 0 40 DCT-CHOICE TESTC --> \ Edt-filter 08:39 03/23/88 : EDT-FILTER ( --- ) TESTC CH.DADDR D.NA @ 1+ 14 MIN FILTERW WINDOW-#ROW C! " Field Filter" NONE DOUBLE FILTERW OPEN-WINDOW FILTERW WINDOW-#ROW C@ 22 SWAP FILTERW NOR 207 WND-CHAR! FILTERW TESTC DCT-CHOOSE DROP FILTERW CLOSE-WINDOW ; --> \ reads 12:53 04/15/88 : READ-FLT TESTC 5 + @ HCB>N -EXT " .FLT" +EXT FLT.FIL NAME>HCB FLT.FIL 2 FOPEN DROP FLT.FIL 0. 0 FSEEK 2DROP FLT.FIL FLT.BUFF SIZEOF FILTER 15 * FREAD DROP FLT.FIL FCLOSE DROP ; : WRITE-FLT FLT.FIL 2 FOPEN DROP FLT.FIL 0. 0 FSEEK 2DROP FLT.FIL FLT.BUFF SIZEOF FILTER 15 * FWRITE DROP FLT.FIL FCLOSE DROP ; --> \ @filters 09:50 03/24/88 CHSTR 3 18 18 CHOICE FILTERC \ operation mode : RBEFILT -ROT TESTC 5 + ! EQU FLT.BUFF READ-FLT " Filters" MENUL SINGLE CHOICEW OPEN-WINDOW BEGIN CHOICEW FILTERC CHOOSE CASE 0 OF NOOP -1 ENDOF 1 OF EDT-FILTER 0 ENDOF 2 OF DROP -1 -1 ENDOF 3 OF DROP 0 -1 ENDOF ENDCASE UNTIL WRITE-FLT CHOICEW CLOSE-WINDOW ; EXCISE FLT.BUFF DUMMY
