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 IN: source-files
   8
   9 SYMBOL: source-files
  10
  11 TUPLE: source-file
  12 path
  13 top-level-form
  14 checksum
  15 definitions
  16 main ;
  17
  18 : record-top-level-form ( quot source-file -- )
  19     top-level-form<<
  20     [ ] [ f notify-definition-observers ] if-bootstrapping ;
  21
  22 : record-checksum ( lines source-file -- )
  23     [ crc32 checksum-lines ] dip checksum<< ;
  24
  25 : record-definitions ( source-file -- )
  26     new-definitions get >>definitions drop ;
  27
  28 : <source-file> ( path -- source-file )
  29     \ source-file new
  30         swap >>path
  31         <definitions> >>definitions ;
  32
  33 ERROR: invalid-source-file-path path ;
  34
  35 : path>source-file ( path -- source-file )
  36     dup string? [ invalid-source-file-path ] unless
  37     source-files get [ <source-file> ] cache ;
  38
  39 : reset-checksums ( -- )
  40     source-files get [
  41         over exists? [
  42             [ utf8 file-lines ] dip record-checksum
  43         ] [ 2drop ] if
  44     ] assoc-each ;
  45
  46 M: pathname where string>> 1 2array ;
  47
  48 : forget-source ( path -- )
  49     source-files get delete-at*
  50     [ definitions>> [ members forget-all ] each ] [ drop ] if ;
  51
  52 M: pathname forget*
  53     string>> forget-source ;
  54
  55 : rollback-source-file ( source-file -- )
  56     [
  57         new-definitions get [ union ] 2map
  58     ] change-definitions drop ;
  59
  60 SYMBOL: current-source-file
  61
  62 : wrap-source-file-error ( error -- * )
  63     current-source-file get rollback-source-file
  64     source-file-error new
  65         f >>line#
  66         current-source-file get path>> >>path
  67         swap >>error rethrow ;
  68
  69 : with-source-file ( name quot -- )
  70     ! Should be called from inside with-compilation-unit.
  71     [
  72         [
  73             path>source-file
  74             [ current-source-file set ]
  75             [ definitions>> old-definitions set ] bi
  76         ] dip
  77         [ wrap-source-file-error ] recover
  78     ] with-scope ; inline