core/source-files/source-files.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs checksums checksums.crc32
   4 compiler.units continuations definitions io.encodings.utf8
   5 io.files io.pathnames kernel namespaces sequences sets
   6 source-files.errors strings words ;
   7 FROM: namespaces => set ;
   8 IN: source-files
   9
  10 SYMBOL: source-files
  11
  12 TUPLE: source-file
  13 path
  14 top-level-form
  15 checksum
  16 definitions
  17 main ;
  18
  19 : record-top-level-form ( quot source-file -- )
  20     top-level-form<<
  21     [ ] [ f notify-definition-observers ] if-bootstrapping ;
  22
  23 : record-checksum ( lines source-file -- )
  24     [ crc32 checksum-lines ] dip checksum<< ;
  25
  26 : record-definitions ( source-file -- )
  27     new-definitions get >>definitions drop ;
  28
  29 : <source-file> ( path -- source-file )
  30     \ source-file new
  31         swap >>path
  32         <definitions> >>definitions ;
  33
  34 ERROR: invalid-source-file-path path ;
  35
  36 : path>source-file ( path -- source-file )
  37     dup string? [ invalid-source-file-path ] unless
  38     source-files get [ <source-file> ] cache ;
  39
  40 : reset-checksums ( -- )
  41     source-files get [
  42         over exists? [
  43             [ utf8 file-lines ] dip record-checksum
  44         ] [ 2drop ] if
  45     ] assoc-each ;
  46
  47 M: pathname where string>> 1 2array ;
  48
  49 : forget-source ( path -- )
  50     source-files get delete-at*
  51     [ definitions>> [ members forget-all ] each ] [ drop ] if ;
  52
  53 M: pathname forget*
  54     string>> forget-source ;
  55
  56 : rollback-source-file ( source-file -- )
  57     [
  58         new-definitions get [ union ] 2map
  59     ] change-definitions drop ;
  60
  61 SYMBOL: current-source-file
  62
  63 : wrap-source-file-error ( error -- * )
  64     current-source-file get rollback-source-file
  65     source-file-error new
  66         f >>line#
  67         current-source-file get path>> >>path
  68         swap >>error rethrow ;
  69
  70 : with-source-file ( name quot -- )
  71     #! Should be called from inside with-compilation-unit.
  72     [
  73         [
  74             path>source-file
  75             [ current-source-file set ]
  76             [ definitions>> old-definitions set ] bi
  77         ] dip
  78         [ wrap-source-file-error ] recover
  79     ] with-scope ; inline