2007-09-20 18:09:08 -04:00
|
|
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
USING: kernel namespaces arrays sequences io inference.backend
|
|
|
|
generator debugger math.parser prettyprint words continuations
|
2007-12-17 16:29:54 -05:00
|
|
|
vocabs assocs alien.compiler dlists optimizer ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: compiler
|
|
|
|
|
2007-12-17 16:29:54 -05:00
|
|
|
SYMBOL: compiler-hook
|
|
|
|
|
|
|
|
: compile-begins ( word -- )
|
|
|
|
compiler-hook get [ call ] when*
|
|
|
|
"quiet" get [ drop ] [ "Compiling " write . flush ] if ;
|
|
|
|
|
|
|
|
: (compile) ( word -- )
|
|
|
|
dup compiling? not over compound? and [
|
|
|
|
[
|
|
|
|
dup compile-begins
|
|
|
|
dup dup word-dataflow nip optimize generate
|
|
|
|
] curry [ print-error ] recover
|
|
|
|
] [ drop ] if ;
|
|
|
|
|
|
|
|
: finish-compilation-unit ( assoc -- )
|
|
|
|
[ swap add* ] { } assoc>map modify-code-heap ;
|
|
|
|
|
|
|
|
: with-compilation-unit ( quot -- )
|
|
|
|
[
|
|
|
|
<dlist> compile-queue set
|
|
|
|
H{ } clone compiled-xts set
|
|
|
|
call
|
|
|
|
compile-queue get [ (compile) ] dlist-slurp
|
|
|
|
compiled-xts get finish-compilation-unit
|
|
|
|
] with-scope ; inline
|
|
|
|
|
2007-12-16 20:35:00 -05:00
|
|
|
: compile-batch ( words -- )
|
2007-12-17 16:29:54 -05:00
|
|
|
[ [ queue-compile ] each ] with-compilation-unit ;
|
2007-12-16 15:17:28 -05:00
|
|
|
|
2007-12-17 16:29:54 -05:00
|
|
|
: compile ( word -- )
|
|
|
|
[ queue-compile ] with-compilation-unit ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2007-12-17 16:29:54 -05:00
|
|
|
: compile-vocabs ( seq -- )
|
|
|
|
[ words ] map concat compile-batch ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2007-12-17 16:29:54 -05:00
|
|
|
: compile-quot ( quot -- word )
|
|
|
|
define-temp dup compile ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2007-12-17 16:29:54 -05:00
|
|
|
: compile-1 ( quot -- )
|
|
|
|
compile-quot execute ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: recompile ( -- )
|
|
|
|
changed-words get [
|
|
|
|
dup keys compile-batch clear-assoc
|
|
|
|
] when* ;
|
|
|
|
|
2007-12-16 18:42:56 -05:00
|
|
|
: forget-errors ( seq -- )
|
|
|
|
[ f "no-effect" set-word-prop ] each ;
|
|
|
|
|
|
|
|
: compile-all ( -- )
|
2007-12-16 20:35:00 -05:00
|
|
|
all-words
|
|
|
|
dup forget-errors [ changed-word ] each
|
|
|
|
recompile ;
|