2008-03-13 05:54:33 -04:00
|
|
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-03-13 05:54:33 -04:00
|
|
|
USING: arrays definitions generic assocs kernel math namespaces
|
2008-07-28 23:28:13 -04:00
|
|
|
sequences strings vectors words quotations io
|
2008-07-28 23:03:13 -04:00
|
|
|
combinators sorting splitting math.parser effects continuations
|
|
|
|
io.files checksums checksums.crc32 vocabs hashtables graphs
|
|
|
|
compiler.units io.encodings.utf8 accessors ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: source-files
|
|
|
|
|
|
|
|
SYMBOL: source-files
|
|
|
|
|
|
|
|
TUPLE: source-file
|
|
|
|
path
|
2008-03-13 05:54:33 -04:00
|
|
|
checksum
|
2007-09-20 18:09:08 -04:00
|
|
|
uses definitions ;
|
|
|
|
|
2008-01-09 21:13:59 -05:00
|
|
|
: record-checksum ( lines source-file -- )
|
2008-08-30 13:34:37 -04:00
|
|
|
[ crc32 checksum-lines ] dip (>>checksum) ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: (xref-source) ( source-file -- pathname uses )
|
2008-08-30 13:34:37 -04:00
|
|
|
[ path>> <pathname> ]
|
|
|
|
[ uses>> [ crossref? ] filter ] bi ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: xref-source ( source-file -- )
|
|
|
|
(xref-source) crossref get add-vertex ;
|
|
|
|
|
|
|
|
: unxref-source ( source-file -- )
|
|
|
|
(xref-source) crossref get remove-vertex ;
|
|
|
|
|
|
|
|
: xref-sources ( -- )
|
|
|
|
source-files get [ nip xref-source ] assoc-each ;
|
|
|
|
|
|
|
|
: record-form ( quot source-file -- )
|
2008-08-30 13:34:37 -04:00
|
|
|
tuck unxref-source
|
|
|
|
quot-uses keys >>uses
|
2007-09-20 18:09:08 -04:00
|
|
|
xref-source ;
|
|
|
|
|
2007-12-21 21:18:24 -05:00
|
|
|
: record-definitions ( file -- )
|
2008-08-30 13:34:37 -04:00
|
|
|
new-definitions get >>definitions drop ;
|
2007-12-21 21:18:24 -05:00
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: <source-file> ( path -- source-file )
|
2008-06-30 06:22:05 -04:00
|
|
|
\ source-file new
|
|
|
|
swap >>path
|
|
|
|
<definitions> >>definitions ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-08-30 13:34:37 -04:00
|
|
|
ERROR: invalid-source-file-path path ;
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: source-file ( path -- source-file )
|
2008-08-30 13:34:37 -04:00
|
|
|
dup string? [ invalid-source-file-path ] unless
|
2007-09-20 18:09:08 -04:00
|
|
|
source-files get [ <source-file> ] cache ;
|
|
|
|
|
|
|
|
: reset-checksums ( -- )
|
|
|
|
source-files get [
|
2008-03-27 00:47:51 -04:00
|
|
|
swap dup exists? [
|
2008-03-04 18:51:40 -05:00
|
|
|
utf8 file-lines swap record-checksum
|
2008-03-03 17:44:24 -05:00
|
|
|
] [ 2drop ] if
|
2007-09-20 18:09:08 -04:00
|
|
|
] assoc-each ;
|
|
|
|
|
|
|
|
M: pathname where pathname-string 1 2array ;
|
|
|
|
|
2008-01-09 19:13:26 -05:00
|
|
|
: forget-source ( path -- )
|
2008-04-03 22:43:41 -04:00
|
|
|
[
|
|
|
|
source-file
|
|
|
|
[ unxref-source ]
|
|
|
|
[ definitions>> [ keys forget-all ] each ]
|
|
|
|
bi
|
|
|
|
]
|
|
|
|
[ source-files get delete-at ]
|
|
|
|
bi ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-01-09 19:13:26 -05:00
|
|
|
M: pathname forget*
|
|
|
|
pathname-string forget-source ;
|
2007-12-21 21:18:24 -05:00
|
|
|
|
2008-03-11 20:51:58 -04:00
|
|
|
: rollback-source-file ( file -- )
|
2008-08-30 13:34:37 -04:00
|
|
|
[
|
|
|
|
new-definitions get [ assoc-union ] 2map
|
|
|
|
] change-definitions drop ;
|
2007-12-21 21:18:24 -05:00
|
|
|
|
|
|
|
SYMBOL: file
|
|
|
|
|
2008-06-25 04:25:08 -04:00
|
|
|
TUPLE: source-file-error file error ;
|
|
|
|
|
|
|
|
: <source-file-error> ( msg -- error )
|
|
|
|
\ source-file-error new
|
|
|
|
file get >>file
|
|
|
|
swap >>error ;
|
|
|
|
|
2007-12-21 21:18:24 -05:00
|
|
|
: with-source-file ( name quot -- )
|
|
|
|
#! Should be called from inside with-compilation-unit.
|
|
|
|
[
|
|
|
|
swap source-file
|
|
|
|
dup file set
|
2008-08-30 13:34:37 -04:00
|
|
|
definitions>> old-definitions set
|
2008-06-25 04:25:08 -04:00
|
|
|
[
|
|
|
|
file get rollback-source-file
|
|
|
|
<source-file-error> rethrow
|
|
|
|
] recover
|
2007-12-21 21:18:24 -05:00
|
|
|
] with-scope ; inline
|