core/source-files/source-files.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays definitions generic assocs kernel math namespaces
   4 prettyprint sequences strings vectors words quotations inspector
   5 io.styles io combinators sorting splitting math.parser effects
   6 continuations debugger io.files checksums checksums.crc32 vocabs
   7 hashtables graphs compiler.units io.encodings.utf8 accessors ;
   8 IN: source-files
   9
  10 SYMBOL: source-files
  11
  12 TUPLE: source-file
  13 path
  14 checksum
  15 uses definitions ;
  16
  17 : record-checksum ( lines source-file -- )
  18     >r crc32 checksum-lines r> set-source-file-checksum ;
  19
  20 : (xref-source) ( source-file -- pathname uses )
  21     dup source-file-path <pathname>
  22     swap source-file-uses [ crossref? ] filter ;
  23
  24 : xref-source ( source-file -- )
  25     (xref-source) crossref get add-vertex ;
  26
  27 : unxref-source ( source-file -- )
  28     (xref-source) crossref get remove-vertex ;
  29
  30 : xref-sources ( -- )
  31     source-files get [ nip xref-source ] assoc-each ;
  32
  33 : record-form ( quot source-file -- )
  34     dup unxref-source
  35     swap quot-uses keys over set-source-file-uses
  36     xref-source ;
  37
  38 : record-definitions ( file -- )
  39     new-definitions get swap set-source-file-definitions ;
  40
  41 : <source-file> ( path -- source-file )
  42     \ source-file new
  43         swap >>path
  44         <definitions> >>definitions ;
  45
  46 : source-file ( path -- source-file )
  47     dup string? [ "Invalid source file path" throw ] unless
  48     source-files get [ <source-file> ] cache ;
  49
  50 : reset-checksums ( -- )
  51     source-files get [
  52         swap dup exists? [
  53             utf8 file-lines swap record-checksum
  54         ] [ 2drop ] if
  55     ] assoc-each ;
  56
  57 M: pathname where pathname-string 1 2array ;
  58
  59 : forget-source ( path -- )
  60     [
  61         source-file
  62         [ unxref-source ]
  63         [ definitions>> [ keys forget-all ] each ]
  64         bi
  65     ]
  66     [ source-files get delete-at ]
  67     bi ;
  68
  69 M: pathname forget*
  70     pathname-string forget-source ;
  71
  72 : rollback-source-file ( file -- )
  73     dup source-file-definitions new-definitions get [ assoc-union ] 2map
  74     swap set-source-file-definitions ;
  75
  76 SYMBOL: file
  77
  78 TUPLE: source-file-error file error ;
  79
  80 : <source-file-error> ( msg -- error )
  81     \ source-file-error new
  82         file get >>file
  83         swap >>error ;
  84
  85 : file. ( file -- ) path>> <pathname> . ;
  86
  87 M: source-file-error error.
  88     [ file>> file. ] [ error>> error. ] bi ;
  89
  90 M: source-file-error summary
  91     error>> summary ;
  92
  93 M: source-file-error compute-restarts
  94     error>> compute-restarts ;
  95
  96 M: source-file-error error-help
  97     error>> error-help ;
  98
  99 : with-source-file ( name quot -- )
 100     #! Should be called from inside with-compilation-unit.
 101     [
 102         swap source-file
 103         dup file set
 104         source-file-definitions old-definitions set
 105         [
 106             file get rollback-source-file
 107             <source-file-error> rethrow
 108         ] recover
 109     ] with-scope ; inline