Annotation of gforth/etags.fs, revision 1.2

1.1       anton       1: \ Etags support for GNU Forth.
                      2: 
                      3: \ This does not work like etags; instead, the TAGS file is updated
                      4: \ during the normal Forth interpretation/compilation process.
                      5: 
                      6: \ The present version has several shortcomings: It always overwrites
                      7: \ the TAGS file instead of just the parts corresponding to the loaded
                      8: \ files, but you can have several tag tables in emacs. Every load
                      9: \ creates a new etags file and the user has to confirm that she wants
                     10: \ to use it.
                     11: 
                     12: \ Communication of interactive programs like emacs and Forth over
                     13: \ files is clumsy. There should be better cooperation between them
                     14: \ (e.g. via shared memory)
                     15: 
                     16: \ This is ANS Forth with the following serious environmental
                     17: \ dependences: the variable LAST must contain a pointer to the last
                     18: \ header, NAME>STRING must convert that pointer to a string, and
                     19: \ HEADER must be a deferred word that is called to create the name.
                     20: 
                     21: : tags-file-name ( -- c-addr u )
                     22:     \ for now I use just TAGS; this may become more flexible in the
                     23:     \ future
                     24:     s" TAGS" ;
                     25: 
                     26: variable tags-file 0 tags-file !
                     27: 
                     28: create tags-line 128 chars allot
                     29:     
                     30: : skip-tags ( file-id -- )
                     31:     \ reads in file until it finds the end or the loadfilename
                     32:     drop ;
                     33: 
                     34: : tags-file-id ( -- file-id )
                     35:     tags-file @ 0= if
                     36:        tags-file-name w/o create-file throw
                     37: \      2dup file-status
                     38: \      if \ the file does not exist
                     39: \          drop w/o create-file throw
                     40: \      else
                     41: \          drop r/w open-file throw
                     42: \          dup skip-tags
                     43: \      endif
                     44:        tags-file !
                     45:     endif
                     46:     tags-file @ ;
                     47: 
                     48: create emit-file-char 0 c,
                     49: 
                     50: : emit-file ( c file-id -- )
                     51:     swap emit-file-char c!
                     52:     emit-file-char 1 chars rot write-file ;
                     53: 
                     54: 2variable last-loadfilename 0 0 last-loadfilename 2!
                     55: 
                     56: : put-load-file-name ( file-id -- )
                     57:     >r
                     58:     loadfilename 2@ last-loadfilename 2@ d<>
                     59:     if
                     60:        #ff r@ emit-file throw
                     61:        #lf r@ emit-file throw
                     62:        loadfilename 2@ 2dup
                     63:        r@ write-file throw
                     64:        last-loadfilename 2!
                     65:        s" ,0" r@ write-line throw
                     66:     endif
                     67:     rdrop ;
                     68: 
                     69: : put-tags-entry ( -- )
                     70:     \ write the entry for the last name to the TAGS file
                     71:     \ if the input is from a file and it is not a local name
                     72:     source-id dup 0<> swap -1 <> and   \ input from a file
                     73:     get-current locals-list <> and     \ not a local name
                     74:     last @ 0<> and     \ not an anonymous (i.e. noname) header
                     75:     if
                     76:        tags-file-id >r 
                     77:        r@ put-load-file-name
                     78:        source drop >in @ r@ write-file throw
                     79:        127 r@ emit-file throw
1.2     ! pazsan     80:        bl r@ emit-file throw
1.1       anton      81:        last @ name>string r@ write-file throw
1.2     ! pazsan     82:        bl r@ emit-file throw
1.1       anton      83:        1 r@ emit-file throw
                     84:        base @ decimal loadline @ 0 <# #s #> r@ write-file throw base !
                     85:        s" ,0" r@ write-line throw
                     86:        \ the character position in the file; not strictly necessary AFAIK
                     87:        \ instead of using 0, we could use file-position and subtract
                     88:        \ the line length
                     89:        rdrop
1.2     ! pazsan     90:     endif cr ;
1.1       anton      91: 
                     92: : (tags-header) ( -- )
                     93:     defers header
                     94:     put-tags-entry ;
                     95: 
                     96: ' (tags-header) IS header

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>