core/compiler/units/units.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel continuations assocs namespaces sequences words
   4 vocabs definitions hashtables init sets ;
   5 IN: compiler.units
   6
   7 SYMBOL: old-definitions
   8 SYMBOL: new-definitions
   9
  10 TUPLE: redefine-error def ;
  11
  12 : redefine-error ( definition -- )
  13     \ redefine-error boa
  14     { { "Continue" t } } throw-restarts drop ;
  15
  16 : add-once ( key assoc -- )
  17     2dup key? [ over redefine-error ] when conjoin ;
  18
  19 : (remember-definition) ( definition loc assoc -- )
  20     >r over set-where r> add-once ;
  21
  22 : remember-definition ( definition loc -- )
  23     new-definitions get first (remember-definition) ;
  24
  25 : remember-class ( class loc -- )
  26     over new-definitions get first key? [ dup redefine-error ] when
  27     new-definitions get second (remember-definition) ;
  28
  29 : forward-reference? ( word -- ? )
  30     dup old-definitions get assoc-stack
  31     [ new-definitions get assoc-stack not ]
  32     [ drop f ] if ;
  33
  34 SYMBOL: recompile-hook
  35
  36 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
  37
  38 SYMBOL: definition-observers
  39
  40 GENERIC: definitions-changed ( assoc obj -- )
  41
  42 [ V{ } clone definition-observers set-global ]
  43 "compiler.units" add-init-hook
  44
  45 : add-definition-observer ( obj -- )
  46     definition-observers get push ;
  47
  48 : remove-definition-observer ( obj -- )
  49     definition-observers get delete ;
  50
  51 : notify-definition-observers ( assoc -- )
  52     definition-observers get
  53     [ definitions-changed ] with each ;
  54
  55 : changed-vocabs ( assoc -- vocabs )
  56     [ drop word? ] assoc-filter
  57     [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
  58
  59 : updated-definitions ( -- assoc )
  60     H{ } clone
  61     dup forgotten-definitions get update
  62     dup new-definitions get first update
  63     dup new-definitions get second update
  64     dup changed-definitions get update
  65     dup dup changed-vocabs update ;
  66
  67 : compile ( words -- )
  68     recompile-hook get call
  69     dup [ drop crossref? ] assoc-contains?
  70     modify-code-heap ;
  71
  72 SYMBOL: outdated-tuples
  73 SYMBOL: update-tuples-hook
  74
  75 : call-recompile-hook ( -- )
  76     changed-definitions get [ drop word? ] assoc-filter
  77     compiled-usages recompile-hook get call ;
  78
  79 : call-update-tuples-hook ( -- )
  80     update-tuples-hook get call ;
  81
  82 : finish-compilation-unit ( -- )
  83     call-recompile-hook
  84     call-update-tuples-hook
  85     dup [ drop crossref? ] assoc-contains? modify-code-heap ;
  86
  87 : with-nested-compilation-unit ( quot -- )
  88     [
  89         H{ } clone changed-definitions set
  90         H{ } clone outdated-tuples set
  91         [ finish-compilation-unit ] [ ] cleanup
  92     ] with-scope ; inline
  93
  94 : with-compilation-unit ( quot -- )
  95     [
  96         H{ } clone changed-definitions set
  97         H{ } clone forgotten-definitions set
  98         H{ } clone outdated-tuples set
  99         H{ } clone new-classes set
 100         <definitions> new-definitions set
 101         <definitions> old-definitions set
 102         [
 103             finish-compilation-unit
 104             updated-definitions
 105             notify-definition-observers
 106         ] [ ] cleanup
 107     ] with-scope ; inline
 108
 109 : compile-call ( quot -- )
 110     [ define-temp ] with-compilation-unit execute ;
 111
 112 : default-recompile-hook ( words -- alist )
 113     [ f ] { } map>assoc ;
 114
 115 recompile-hook global
 116 [ [ default-recompile-hook ] or ]
 117 change-at