home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / ind.seq < prev    next >
Text File  |  1991-03-14  |  20KB  |  448 lines
  1. \ INDEX.SEQ    Build an index of hyper text links      by Tom Zimmer
  2.  
  3. ' lrhndl alias seqhandle
  4.  
  5.  36 array slook.buf
  6. 128 array joined$
  7.  
  8. defer donfile           \ A function to do on all specified files
  9.  
  10. : ?ESC          ( -- f1 )
  11.                 key?
  12.                 if      key 27 =
  13.                 else    false
  14.                 then    ;
  15.  
  16. handle indhndl
  17.  
  18. : search_1file  ( n1 -- )
  19.                 >fadr dir>pad >r
  20.                 here indhndl $>handle
  21.                 indhndl >pathend
  22.                 dup indhndl 1+ - r@ + indhndl c!
  23.                 r> cmove
  24.                 indhndl count + off
  25.                 indhndl hopen 0=
  26.                 indhndl save!> seqhandle
  27.                 ibreset
  28.                 if      donfile
  29.                 then
  30.                 indhndl hclose drop
  31.                 restore> seqhandle ;
  32.  
  33. : $fallof        ( addr-offile_spec --- )
  34.                                         \ Do something to all files
  35.                                         \ matching file_specs.
  36.                 dirseg 0=
  37.                 if drop exit then
  38.                 dup count here c! here count cmove
  39.                                         \ need spec at HERE also
  40.                 $getdir                 \ and read the directory files.
  41.                 #fls
  42.                 if      #fls 0
  43.                         ?do     i >fadr 1+ c@l '.' <>
  44.                                 if      i search_1file
  45.                                 then    ?esc ?leave
  46.                         loop
  47.                 then    ;
  48.  
  49. handle indexhndl
  50. 0 value ?exp_tabs
  51. 0 value after
  52. 0 value before
  53. 0 value stopper
  54. 0 value fstime
  55. 0 value ?global
  56. 2variable thisline
  57. create crlf$ $0D c,-d $0A c,-d
  58.  
  59. : write.filename ( -- )
  60.                 fstime ?exit    \ put filename in index file
  61.                 " ∙" indexhndl hwrite drop
  62.                 ?global
  63.                 if      indhndl count     indexhndl hwrite drop
  64.                 else    indhndl >pathend" indexhndl hwrite drop
  65.                 then
  66.                 crlf$ 2 indexhndl hwrite drop
  67.                 on> fstime ;
  68.  
  69. : write.onename ( a1 n1 -- )
  70.                 write.filename
  71.                 indexhndl hwrite drop           \ write to file
  72.                 loadline @                      \ line where found,
  73.                 0 <# $0A hold $0D hold          \ end line with CRLF
  74.                 #S                              \ preceeded by the number
  75.                 bl hold #>                      \ preceeded by a blank
  76.                 indexhndl hwrite drop ;         \ write it too.
  77.  
  78. : skip_1word    ( a1 n1 -- a2 n2 )      \ skip one word through string
  79.                 begin   2dup bl scan    \ find a blank
  80.                         bl skip         \ and skip it
  81.                         dup             \ any text left
  82.                 while   2swap 2drop
  83.                 repeat  2drop  ;        \ if any text left, then
  84.  
  85. : ?word.ending  ( -- )  \ find a word ending with char in slook.buf
  86.                 thisline 2@ over c@ bl =        \ mustn't start with a blank
  87.         if      2drop
  88.         else    bl skip                         \ skip leading spaces
  89.                 2dup slook.buf 1+ c@ scan dup   \ did we find delimit char
  90.                 if      over 1+ c@ bl =         \ does a blank follow char?
  91.                                                 \ if so then ok, else not
  92.                    if   nip -                   \ parse word before
  93.                         skip_1word dup          \ if any text left, then
  94.                         if      write.onename   \ write name to index
  95.                         else    2drop
  96.                         then
  97.                    else 2drop 2drop
  98.                    then
  99.                 else    2drop 2drop             \ discard if not found
  100.                 then
  101.  
  102.         then ;
  103.  
  104. : write.1cname  ( -- )
  105.                 thisline 2@ bl skip     \ skip leading blanks
  106.                 2dup '(' scan nip -     \ up to "("
  107.                 begin   2dup  bl scan dup       \ any blanks?
  108.                 while   2swap 2drop
  109.                         bl skip         \ then skip them
  110.                 repeat  2drop
  111.                 write.onename   ;       \ and write one index name
  112.  
  113. : ?word.C       ( -- )  \ find a "C" function name
  114.                 thisline 2@ '(' scan dup        \ if we find a (
  115.         if      2dup ';' scan nip >r            \ and
  116.                      '{' scan nip r> >=         \ if { before ; or neither
  117.                                                 \ is found, then
  118.                 if      write.1cname
  119.                 then
  120.         else    2drop
  121.         then    ;
  122.  
  123. : ?word.prev    ( -- )  \ find occurances of slook.buf string and put word
  124.                         \ previous to string in index file with line number.
  125.                 slook.buf count thisline 2@ search nip
  126.                 if      thisline 2@ bl skip     \ skip those blanks
  127.                         2dup bl scan nip -      \ addr and len of name
  128.                         write.onename           \ and write one index name
  129.                 then ;
  130.  
  131. long_branch
  132.  
  133. : ?word.after   ( -- )  \ find occurances of slook.buf string and put word
  134.                         \ following string in index file with line number.
  135.                 slook.buf count thisline 2@
  136.                 2dup '\' scan nip -             \ stop at '\'
  137.                 begin   4dup search             \ while found
  138.                 while   /string                 \ strip preceeding text
  139.                         over 1- dup c@ bl =     \ preceed with BL
  140.                         swap outbuf = or >r     \ or at line start
  141.                         slook.buf c@ /string    \ skip search string + leadin
  142.                         bl skip dup r> and      \ skip those blanks
  143.                                                 \ must have text left
  144.                     if                          \ it anything left
  145.                         2dup                    \ -- addr & len of string
  146.                                                 \ then get word following
  147.                         2dup bl scan nip -      \ addr and len of name
  148.                         write.onename           \ and write one index name
  149.                     then
  150.                 repeat  drop 2drop 2drop ;
  151.  
  152. : ?word.stline  ( -- )  \ find occurance of slook.buf string at line start
  153.                         \ put following string in index file.
  154.                 thisline 2@ 2dup bl scan nip - dup
  155.                 if      slook.buf count rot max compare 0=
  156.                         if      thisline 2@ bl scan     \ find a blank
  157.                                 bl skip dup             \ skip those blanks
  158.                                 if                      \ if anything left
  159.                                         2dup bl scan nip -  \ word following
  160.                                         write.onename   \ write 1 index name
  161.                                 else    2drop
  162.                                 then
  163.                         then
  164.                 else    2drop
  165.                 then ;
  166.  
  167. short_branch
  168.  
  169. : search.word   ( n1 -- )
  170.                 0max 4 min exec:
  171.                 ?word.after     ?word.ending    ?word.prev
  172.                 ?word.C         ?word.stline    ;
  173.  
  174.                 2variable curspec
  175.  32             constant b/tbl
  176.  16             constant maxtbl
  177.   0             value    tblcnt
  178. 132             array fl$
  179. b/tbl maxtbl *  array wtbl
  180.  
  181. : search.words  ( -- )
  182.                 wtbl b/tbl maxtbl * bounds
  183.                 do      i 1+ c@ 0= ?leave
  184.                         i 1+ count slook.buf place
  185.                         i c@ search.word
  186.          b/tbl +loop    ;
  187.  
  188.  
  189. : nfl$          ( -- a1 )
  190.                 curspec 2@ bl skip              \ skip blanks
  191.                 2dup bl scan                    \ find next blank
  192.                 2dup curspec 2!                 \ save for next try
  193.                 nip - pad place                 \ put it in pad
  194.                 pad ;                           \ ( -- pad )    return pad
  195.  
  196.  
  197. : 0fl$          ( -- a1 )
  198.                 fl$ count curspec 2!            \ reset to spec's start
  199.                 nfl$ ;                          \ next spec
  200.  
  201. : ilineread     ( -- a1 )               \ index line read, with tab expand
  202.                 lineread                        \ read a line from file
  203.                 ?exp_tabs 0= ?exit              \ leave if not expanding tabs
  204.                 dup count                       \ through whole line
  205.                 begin   $09 scan dup            \ look for next tab char
  206.                 while   over bl swap c!         \ change tab to blank
  207.                 repeat  2drop ;
  208.  
  209. long_branch
  210.  
  211. : next-cmd$     ( a1 n1 -- f1 )         \ find next matching string line
  212.                                         \ f1 = true if match
  213.                 begin   2dup
  214.                         ilineread crlf>bl's
  215.                         count bl skip 2dup              \ skip leading spcs
  216.                         bl scan nip -                   \ parse first word
  217.                         rot max caps-comp 0=            \ compare strings =
  218.                         outbuf c@ 0= or                 \ or empty lineread
  219.                         outbuf c@ ';' =                 \ test for file stop
  220.                         if      true or                 \ say we are done
  221.                                 outbuf off              \ clear buffer
  222.                         then
  223.                 until   2drop outbuf c@ ;               \ true if matched
  224.  
  225. short_branch
  226.  
  227. : find-cmd$     ( a1 n1 -- f1 )         \ find a line starting with string
  228.                                         \ a1,n1. f1 = true if matched
  229.                 ibreset
  230.                 0.0 seqhandle movepointer
  231.                 next-cmd$ ;
  232.  
  233. : after-cmd     ( -- a1 n1 )            \ return a1,n1 string after command
  234.                 outbuf count
  235.                 bl skip bl scan         \ past first word
  236.                 bl skip ;               \ and past any following spcs
  237.  
  238. : read_stopper  ( -- )                  \ STOPAT \
  239.                 " STOPAT" find-cmd$
  240.                 if      after-cmd       \ -- a1 n1
  241.                         if      c@ =: stopper
  242.                         else    drop
  243.                         then
  244.                 then    ;
  245.  
  246. : read_before   ( -- )                  \ BEFORE 64
  247.                 " BEFORE" find-cmd$
  248.                 if      after-cmd       \ -- a1 n1
  249.                         ""->$           \ -- a1         counted string
  250.                         number?         \ -- d1 f1
  251.                         if      over 250 min =: before
  252.                         then    2drop
  253.                 then    ;
  254.  
  255. : read_after    ( -- )                  \ AFTER 35
  256.                 " AFTER" find-cmd$
  257.                 if      after-cmd       \ -- a1 n1
  258.                         ""->$           \ -- a1         counted string
  259.                         number?         \ -- d1 f1
  260.                         2drop 128 min =: after
  261.                 then    ;
  262.  
  263. : read_tabx     ( -- )                  \ TABX ON
  264.                 " TABX" find-cmd$
  265.                 if      after-cmd               \ -- a1 n1
  266.                         ""->$ 1+ dup            \ -- a1         counted string
  267.                         " ON"  caps-comp 0=     \ if "ON" then expand tabs
  268.                         if      drop
  269.                                 on>  ?exp_tabs exit
  270.                         then
  271.                         " OFF" caps-comp 0=     \ if "OFF" then don't expand
  272.                         if      off> ?exp_tabs exit
  273.                         then
  274.                 then    ;
  275.  
  276. : 1word         ( a1 n1 -- a2 n2 a3 n3 )        \ parse out a word
  277.                 bl skip 2dup bl scan 2dup 2>r nip - 2r> 2swap ;
  278.  
  279. : ""->$         ( a1 n1 -- a2 )         \ convert addr & len to counted $
  280.                 over 1- c! 1- ;
  281.  
  282. : nextword      ( a1 n1 -- a2 n2 )      \ skip from current word to next
  283.                 bl scan bl skip ;
  284.  
  285. : read_specs    ( -- )                  \ SPECS *.SEQ;*.TXT;*.ASM
  286.                 " SPECS" find-cmd$
  287.                 if      after-cmd
  288.                         2dup bl scan nip -      \ get line upto a blank
  289.                         132 min fl$ place       \ move in file search string
  290.                         fl$ count
  291.                         begin   ';' scan dup            \ scan for ';'
  292.                         while   over bl swap c!         \ change to blank
  293.                         repeat  2drop
  294.                         fl$ count curspec 2!            \ place to start
  295.                 then    ;
  296.  
  297. : read_global   ( -- )                  \ GLOBAL \
  298.                 " GLOBAL" find-cmd$
  299.                 if      after-cmd
  300.                         2dup bl scan nip -      \ get line upto a blank
  301.                         63 min startdir place   \ move in file search string
  302.                         on> ?global             \ do a global edit
  303.                 then    ;
  304.  
  305. : get1cmd       ( -- )
  306.                 after-cmd                       \ -- a1 n1
  307.                 over c@ '0' - 0 max 9 min       \ type 0 to 9
  308.                 tblcnt b/tbl * wtbl + c!        \ set search type
  309.                 '"' scan 1 /string              \ skip to search $
  310.                 2dup 1 /string                  \ allow " to follow as legal
  311.                 '"' scan nip -                  \ get " delim $
  312.                 b/tbl 2- min                    \ limit to avail
  313.                 tblcnt b/tbl * wtbl + 1+ place  \ move $ into buf
  314.                 incr> tblcnt ;
  315.  
  316. : read_cmds     ( -- )                  \ TYPE 0 "CONSTANT "
  317.                 " TYPE" find-cmd$
  318.                 if      get1cmd
  319.                         begin   " TYPE" next-cmd$
  320.                                 tblcnt maxtbl < and
  321.                         while   get1cmd
  322.                         repeat
  323.                 then    ;
  324.  
  325. : index_open?   ( -- f1 )       \ open and return true, else couldn't
  326.                 " INDEX.CFG" ">$ indexhndl $>handle      \ init filename
  327.                 indexhndl hopen                 \ could we open?
  328.                 if      " \NEWZ.CFG" ">$ indexhndl $>handle
  329.                                                 \ try root if failed above
  330.                         indexhndl hopen 0=
  331.                 else    true
  332.                 then    ;
  333.  
  334. : cfg-init      ( -- )
  335.                 off> after                      \ start looking at 0
  336.                 250 =: before                   \ look up to char 250
  337.                 '\' =: stopper                  \ stop character=\
  338.                 off> tblcnt                     \ command count=0
  339.                 wtbl b/tbl maxtbl * erase       \ initialize table
  340.                 off> ?global                    \ no global searching
  341.                 " \" startdir place ;           \ default to whole disk
  342.  
  343. : read_cfg      ( -- )          \ read the hypertext word table for
  344.                                 \ building the index file.
  345.                 cfg-init
  346.                 index_open?
  347.                 if      indexhndl save!> seqhandle
  348.                         read_specs              \ read file specifications
  349.                         read_global             \ global hyperindex directory
  350.                         read_after              \ read where to start in line
  351.                         read_before             \ read before limit length
  352.                         read_stopper            \ read stop char
  353.                         read_tabx               \ file contains tabs
  354.                         read_cmds               \ read compiler commands
  355.                         restore> seqhandle
  356.                         indexhndl hclose drop
  357.                 else    0 wtbl c!               \ type is zero
  358.                         " °" wtbl 1+ place      \ string is "°"
  359.                 then    ;
  360.  
  361. : ind.1line     ( -- f1 )
  362.                 outbuf count
  363.                 before min after /string
  364.                 2dup stopper scan nip - tuck thisline 2!
  365.                 0>
  366.                 outbuf crlf>bl's 1+ c@ '\' <> and
  367.                 if      search.words
  368.                 then    ;
  369.  
  370. : index.file    ( --- )
  371.                 20 10 at seqhandle count type 60 #out @ - 0 max spaces
  372.                 IBRESET
  373.                 0.0 seqhandle movepointer
  374.                 off> loadline
  375.                 off> fstime
  376.                 20000 1
  377.                 do      ilineread c@ 0= ?leave
  378.                         ind.1line
  379.                         i 64 and 0=
  380.                         if      ?esc ?leave
  381.                         then
  382.                 loop    ;
  383.  
  384. : joindir       ( dir spec -- filespec )        \ join dir & spec to make
  385.                                                 \ a complete filespec
  386.                 swap count joined$ place        \ lay in dir
  387.                 joined$ count + 1- c@ '\' <>
  388.                 if      " \" joined$ +place
  389.                 then
  390.                 count over c@ '\' =
  391.                 if      1 /string
  392.                 then    joined$ +place
  393.                 joined$ ;
  394.  
  395. : global_search ( -- )
  396.                 getdirs
  397.                 begin   nextdir dup c@
  398.                 while   dup 0fl$ joindir $fallof
  399.                         begin   dup nfl$ dup c@
  400.                                 ?esc 0= and     \ leave if ESC pressed
  401.                         while   joindir $fallof
  402.                         repeat  2drop
  403.                 repeat  drop    ;
  404.  
  405. long_branch
  406.  
  407. : bindex        ( --- )
  408.                 savecursor
  409.                 savescr cursor-off
  410.                 18 8 62 12 box&fill
  411.                 ."  Building hyper index file HYPER.NDX... "
  412.                 bcr bcr
  413.                 ."  ESC = cancel "
  414.                 " *.TXT" fl$ place
  415.                 read_cfg
  416.                 " HYPER.NDX" ">$ indexhndl $>handle
  417.                 indexhndl hcreate 0=
  418.                 if      ['] index.file is donfile
  419.                         ?global
  420.                         if      global_search
  421.                         else    0fl$    $fallof
  422.                                 begin   nfl$ dup c@
  423.                                         ?esc 0= and     \ leave if ESC pressed
  424.                                 while   $fallof
  425.                                 repeat  drop
  426.                         then
  427.                         crlf$ 2 indexhndl hwrite drop
  428.                         indexhndl hclose drop
  429.                         1 seconds
  430.                 then    restscr restcursor ;
  431.  
  432. : main          ( -- )
  433.                 DECIMAL                         \ always select decimal
  434.                 INIT-CURSOR                     \ get intial cursor shape
  435.                 50 FUDGE !                      \ init MS timer, GUESS!!
  436.                 CAPS ON                         \ ignore cAsE
  437.                 ?DS: SSEG !                     \ init search segment
  438.                 DOSIO_INIT                      \ init EMIT, TYPE & SPACES
  439.                 $FFF0 SET_MEMORY                \ default to 64k code space
  440.                 DOS_TO_TIB                      \ move command tail to TIB
  441.                 COMSPEC_INIT                    \ init command specification
  442.                 LINEREAD_INIT           \ initialize the LINEREAD system.
  443.                 dirinit                 \ initialize directory words
  444.                 diralloc                \ allocate directory name space
  445.                 bindex ;
  446.  
  447.  
  448.