updated copyright years
1: \ Etags support for GNU Forth. 2: 3: \ Copyright (C) 1995,1998,2001 environ.fs 47: require extend.fs 48: 49: : tags-file-name ( -- c-addr u ) 50: \ for now I use just TAGS; this may become more flexible in the 51: \ future 52: s" TAGS" ; 53: 54: variable tags-file 0 tags-file ! 55: 56: create tags-line 128 chars allot 57: 58: : skip-tags ( file-id -- ) 59: \ reads in file until it finds the end or the loadfilename 60: drop ; 61: 62: : tags-file-id ( -- file-id ) 63: tags-file @ 0= if 64: tags-file-name w/o create-file throw 65: \ 2dup file-status 66: \ if \ the file does not exist 67: \ drop w/o create-file throw 68: \ else 69: \ drop r/w open-file throw 70: \ dup skip-tags 71: \ endif 72: tags-file ! 73: endif 74: tags-file @ ; 75: 76: 2variable last-loadfilename 0 0 last-loadfilename 2! 77: 78: : put-load-file-name ( file-id -- ) 79: >r 80: sourcefilename last-loadfilename 2@ d<> 81: if 82: #ff r@ emit-file throw 83: #lf r@ emit-file throw 84: sourcefilename 2dup 85: r@ write-file throw 86: last-loadfilename 2! 87: s" ,0" r@ write-line throw 88: endif 89: rdrop ; 90: 91: : put-tags-entry ( -- ) 92: \ write the entry for the last name to the TAGS file 93: \ if the input is from a file and it is not a local name 94: source-id dup 0<> swap -1 <> and \ input from a file 95: current @ locals-list <> and \ not a local name 96: latest 0<> and \ not an anonymous (i.e. noname) header 97: if 98: tags-file-id >r 99: r@ put-load-file-name 100: source drop >in @ r@ write-file throw 101: 127 r@ emit-file throw 102: \ bl r@ emit-file throw 103: latest name>string r@ write-file throw 104: \ bl r@ emit-file throw 105: 1 r@ emit-file throw 106: base @ decimal sourceline# 0 <# #s #> r@ write-file throw base ! 107: s" ,0" r@ write-line throw 108: \ the character position in the file; not strictly necessary AFAIK 109: \ instead of using 0, we could use file-position and subtract 110: \ the line length 111: rdrop 112: endif ; 113: 114: : (tags-header) ( -- ) 115: defers header 116: put-tags-entry ; 117: 118: ' (tags-header) IS header