1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays kernel continuations assocs namespaces
4 sequences words vocabs definitions hashtables init sets
5 math math.order classes classes.algebra classes.tuple
6 classes.tuple.private generic source-files.errors ;
9 SYMBOL: old-definitions
10 SYMBOL: new-definitions
12 TUPLE: redefine-error def ;
14 : redefine-error ( definition -- )
16 { { "Continue" t } } throw-restarts drop ;
18 : add-once ( key assoc -- )
19 2dup key? [ over redefine-error ] when conjoin ;
21 : (remember-definition) ( definition loc assoc -- )
22 [ over set-where ] dip add-once ;
24 : remember-definition ( definition loc -- )
25 new-definitions get first (remember-definition) ;
27 : fake-definition ( definition -- )
28 old-definitions get [ delete-at ] with each ;
30 : remember-class ( class loc -- )
31 [ dup new-definitions get first key? [ dup redefine-error ] when ] dip
32 new-definitions get second (remember-definition) ;
34 : forward-reference? ( word -- ? )
35 dup old-definitions get assoc-stack
36 [ new-definitions get assoc-stack not ]
41 HOOK: recompile compiler-impl ( words -- alist )
43 HOOK: to-recompile compiler-impl ( -- words )
45 HOOK: process-forgotten-words compiler-impl ( words -- )
47 ! Non-optimizing compiler
49 [ dup def>> ] { } map>assoc ;
52 changed-definitions get [ drop word? ] assoc-filter
53 changed-generics get assoc-union keys ;
55 M: f process-forgotten-words drop ;
57 : without-optimizer ( quot -- )
58 [ f compiler-impl ] dip with-variable ; inline
60 ! Trivial compiler. We don't want to touch the code heap
61 ! during stage1 bootstrap, it would just waste time.
62 SINGLETON: dummy-compiler
64 M: dummy-compiler to-recompile f ;
66 M: dummy-compiler recompile drop { } ;
68 M: dummy-compiler process-forgotten-words drop ;
70 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
72 SYMBOL: definition-observers
74 GENERIC: definitions-changed ( assoc obj -- )
76 [ V{ } clone definition-observers set-global ]
77 "compiler.units" add-init-hook
79 ! This goes here because vocabs cannot depend on init
80 [ V{ } clone vocab-observers set-global ]
81 "vocabs" add-init-hook
83 : add-definition-observer ( obj -- )
84 definition-observers get push ;
86 : remove-definition-observer ( obj -- )
87 definition-observers get remove-eq! drop ;
89 : notify-definition-observers ( assoc -- )
90 definition-observers get
91 [ definitions-changed ] with each ;
93 : changed-vocabs ( assoc -- vocabs )
94 [ drop word? ] assoc-filter
95 [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
97 : updated-definitions ( -- assoc )
99 dup forgotten-definitions get update
100 dup new-definitions get first update
101 dup new-definitions get second update
102 dup changed-definitions get update
103 dup dup changed-vocabs update ;
105 : compile ( words -- ) recompile modify-code-heap ;
107 : process-forgotten-definitions ( -- )
108 forgotten-definitions get keys
109 [ [ word? ] filter process-forgotten-words ]
110 [ [ delete-definition-errors ] each ]
113 : finish-compilation-unit ( -- )
115 to-recompile recompile
117 process-forgotten-definitions
119 updated-definitions dup assoc-empty?
120 [ drop ] [ notify-definition-observers notify-error-observers ] if ;
122 : with-nested-compilation-unit ( quot -- )
124 H{ } clone changed-definitions set
125 H{ } clone changed-generics set
126 H{ } clone changed-effects set
127 H{ } clone outdated-generics set
128 H{ } clone outdated-tuples set
129 H{ } clone new-classes set
130 [ finish-compilation-unit ] [ ] cleanup
131 ] with-scope ; inline
133 : with-compilation-unit ( quot -- )
135 H{ } clone changed-definitions set
136 H{ } clone changed-generics set
137 H{ } clone changed-effects set
138 H{ } clone outdated-generics set
139 H{ } clone forgotten-definitions set
140 H{ } clone outdated-tuples set
141 H{ } clone new-classes set
142 <definitions> new-definitions set
143 <definitions> old-definitions set
144 [ finish-compilation-unit ] [ ] cleanup
145 ] with-scope ; inline