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 string }
  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     f f <definitions> f source-file boa ;
  30
  31 : path>source-file ( path -- source-file )
  32     source-files get [ <source-file> ] cache ;
  33
  34 : reset-checksums ( -- )
  35     source-files get [
  36         over file-exists? [
  37             [ utf8 file-lines ] dip record-checksum
  38         ] [ 2drop ] if
  39     ] assoc-each ;
  40
  41 M: pathname where string>> 1 2array ;
  42
  43 : forget-source ( path -- )
  44     source-files get delete-at*
  45     [ definitions>> [ members forget-all ] each ] [ drop ] if ;
  46
  47 M: pathname forget*
  48     string>> forget-source ;
  49
  50 : rollback-source-file ( source-file -- )
  51     [
  52         new-definitions get [ union ] 2map
  53     ] change-definitions drop ;
  54
  55 SYMBOL: current-source-file
  56
  57 : wrap-source-file-error ( error -- * )
  58     current-source-file get rollback-source-file
  59     source-file-error new
  60         f >>line#
  61         current-source-file get path>> >>path
  62         swap >>error rethrow ;
  63
  64 : with-source-file ( name quot -- )
  65     ! Should be called from inside with-compilation-unit.
  66     H{ } clone [
  67         [
  68             path>source-file
  69             [ current-source-file namespaces:set ]
  70             [ definitions>> old-definitions namespaces:set ] bi
  71         ] dip
  72         [ wrap-source-file-error ] recover
  73     ] with-variables ; inline