Merge branch 'master' of git://factorcode.org/git/factor
commit
e068fa0e98
|
@ -554,12 +554,19 @@ M: quotation '
|
|||
: fixup-header ( -- )
|
||||
heap-size data-heap-size-offset fixup ;
|
||||
|
||||
: build-generics ( -- )
|
||||
[
|
||||
all-words
|
||||
[ generic? ] filter
|
||||
[ make-generic ] each
|
||||
] with-compilation-unit ;
|
||||
|
||||
: build-image ( -- image )
|
||||
800000 <vector> image set
|
||||
20000 <hashtable> objects set
|
||||
emit-image-header t, 0, 1, -1,
|
||||
"Building generic words..." print flush
|
||||
remake-generics
|
||||
build-generics
|
||||
"Serializing words..." print flush
|
||||
emit-words
|
||||
"Serializing JIT data..." print flush
|
||||
|
|
|
@ -53,3 +53,9 @@ IN: combinators.smart.tests
|
|||
{ 2 0 } [ [ + ] nullary ] must-infer-as
|
||||
|
||||
{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
|
||||
|
||||
: smart-if-test ( a b -- b )
|
||||
[ < ] [ swap - ] [ - ] smart-if ;
|
||||
|
||||
[ 7 ] [ 10 3 smart-if-test ] unit-test
|
||||
[ 16 ] [ 25 41 smart-if-test ] unit-test
|
||||
|
|
|
@ -50,4 +50,4 @@ MACRO: nullary ( quot -- quot' )
|
|||
dup outputs '[ @ _ ndrop ] ;
|
||||
|
||||
MACRO: smart-if ( pred true false -- )
|
||||
'[ _ preserving _ _ if ] ; inline
|
||||
'[ _ preserving _ _ if ] ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: slots arrays definitions generic hashtables summary io kernel
|
||||
math namespaces make prettyprint prettyprint.config sequences assocs
|
||||
|
@ -252,6 +252,8 @@ M: decode-error summary drop "Character decoding error" ;
|
|||
|
||||
M: bad-create summary drop "Bad parameters to create" ;
|
||||
|
||||
M: cannot-be-inline summary drop "This type of word cannot be inlined" ;
|
||||
|
||||
M: attempt-all-error summary drop "Nothing to attempt" ;
|
||||
|
||||
M: already-disposed summary drop "Attempting to operate on disposed object" ;
|
||||
|
|
|
@ -287,7 +287,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
|
|||
: decode-macroblock ( -- blocks )
|
||||
jpeg> components>>
|
||||
[
|
||||
[ mb-dim first2 * iota ]
|
||||
[ mb-dim first2 * ]
|
||||
[ [ decode-block ] curry replicate ] bi
|
||||
] map concat ;
|
||||
|
||||
|
|
|
@ -193,13 +193,12 @@ SYMBOL: interactive-vocabs
|
|||
|
||||
: with-interactive-vocabs ( quot -- )
|
||||
[
|
||||
<manifest> manifest set
|
||||
"scratchpad" set-current-vocab
|
||||
interactive-vocabs get only-use-vocabs
|
||||
call
|
||||
] with-scope ; inline
|
||||
] with-manifest ; inline
|
||||
|
||||
: listener ( -- )
|
||||
[ [ { } (listener) ] with-interactive-vocabs ] with-return ;
|
||||
[ [ { } (listener) ] with-return ] with-interactive-vocabs ;
|
||||
|
||||
MAIN: listener
|
||||
|
|
|
@ -21,3 +21,5 @@ unit-test
|
|||
|
||||
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
|
||||
|
||||
[ ] [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
|
||||
[ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel sequences words effects combinators assocs
|
||||
definitions quotations namespaces memoize accessors
|
||||
|
@ -23,6 +23,8 @@ SYNTAX: MACRO: (:) define-macro ;
|
|||
|
||||
PREDICATE: macro < word "macro" word-prop >boolean ;
|
||||
|
||||
M: macro make-inline cannot-be-inline ;
|
||||
|
||||
M: macro definer drop \ MACRO: \ ; ;
|
||||
|
||||
M: macro definition "macro" word-prop ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts math math.order namespaces sequences
|
||||
sequences.private accessors classes.tuple arrays ;
|
||||
|
@ -16,10 +16,8 @@ M: range length ( seq -- n ) length>> ; inline
|
|||
|
||||
M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
|
||||
|
||||
! For ranges with many elements, the default element-wise methods
|
||||
! sequences define are unsuitable because they're O(n)
|
||||
M: range equal? over range? [ tuple= ] [ 2drop f ] if ;
|
||||
|
||||
! We want M\ tuple hashcode, not M\ sequence hashcode here!
|
||||
! sequences hashcode is O(n) in number of elements
|
||||
M: range hashcode* tuple-hashcode ;
|
||||
|
||||
INSTANCE: range immutable-sequence
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
USING: accessors alien.c-types alien.data byte-arrays
|
||||
combinators.short-circuit continuations destructors init kernel
|
||||
locals namespaces random windows.advapi32 windows.errors
|
||||
windows.kernel32 windows.types math.bitwise ;
|
||||
windows.kernel32 windows.types math.bitwise sequences fry
|
||||
literals ;
|
||||
IN: random.windows
|
||||
|
||||
TUPLE: windows-rng provider type ;
|
||||
|
@ -58,13 +59,23 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
|
|||
[ CryptGenRandom win32-error=0/f ] keep
|
||||
] with-destructors ;
|
||||
|
||||
[
|
||||
MS_DEF_PROV
|
||||
PROV_RSA_FULL <windows-rng> system-random-generator set-global
|
||||
ERROR: no-windows-crypto-provider error ;
|
||||
|
||||
[ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
|
||||
[ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
|
||||
secure-random-generator set-global
|
||||
: try-crypto-providers ( seq -- windows-rng )
|
||||
[ first2 <windows-rng> ] attempt-all
|
||||
dup windows-rng? [ no-windows-crypto-provider ] unless ;
|
||||
|
||||
[
|
||||
{
|
||||
${ MS_ENHANCED_PROV PROV_RSA_FULL }
|
||||
${ MS_DEF_PROV PROV_RSA_FULL }
|
||||
} try-crypto-providers
|
||||
system-random-generator set-global
|
||||
|
||||
{
|
||||
${ MS_STRONG_PROV PROV_RSA_FULL }
|
||||
${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
|
||||
} try-crypto-providers secure-random-generator set-global
|
||||
] "random.windows" add-startup-hook
|
||||
|
||||
[
|
||||
|
|
|
@ -64,12 +64,15 @@ M: rename pprint-qualified ( rename -- )
|
|||
tri
|
||||
] with-pprint ;
|
||||
|
||||
: filter-interesting ( seq -- seq' )
|
||||
[ [ vocab? ] [ extra-words? ] bi or not ] filter ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: (pprint-manifest ( manifest -- quots )
|
||||
[
|
||||
[ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
|
||||
[ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
|
||||
[ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
|
||||
[ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
|
||||
tri
|
||||
] { } make ;
|
||||
|
|
|
@ -31,32 +31,31 @@ architecture get {
|
|||
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
|
||||
|
||||
! Bring up a bare cross-compiling vocabulary.
|
||||
"syntax" vocab vocab-words bootstrap-syntax set {
|
||||
dictionary
|
||||
new-classes
|
||||
changed-definitions changed-generics changed-effects
|
||||
outdated-generics forgotten-definitions
|
||||
root-cache source-files update-map implementors-map
|
||||
} [ H{ } clone swap set ] each
|
||||
"syntax" vocab vocab-words bootstrap-syntax set
|
||||
|
||||
H{ } clone dictionary set
|
||||
H{ } clone root-cache set
|
||||
H{ } clone source-files set
|
||||
H{ } clone update-map set
|
||||
H{ } clone implementors-map set
|
||||
|
||||
init-caches
|
||||
|
||||
bootstrapping? on
|
||||
|
||||
call( -- )
|
||||
call( -- )
|
||||
|
||||
! Vocabulary for slot accessors
|
||||
"accessors" create-vocab drop
|
||||
|
||||
dummy-compiler compiler-impl set
|
||||
|
||||
call( -- )
|
||||
call( -- )
|
||||
call( -- )
|
||||
|
||||
! After we execute bootstrap/layouts
|
||||
num-types get f <array> builtins set
|
||||
|
||||
bootstrapping? on
|
||||
|
||||
[
|
||||
|
||||
call( -- )
|
||||
|
||||
! Create some empty vocabs where the below primitives and
|
||||
! classes will go
|
||||
{
|
||||
|
|
|
@ -6,7 +6,7 @@ io.streams.string kernel kernel.private math math.constants
|
|||
math.order namespaces parser parser.notes prettyprint
|
||||
quotations random see sequences sequences.private slots
|
||||
slots.private splitting strings summary threads tools.test
|
||||
vectors vocabs words words.symbol fry literals ;
|
||||
vectors vocabs words words.symbol fry literals memory ;
|
||||
IN: classes.tuple.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
|
@ -443,14 +443,14 @@ TUPLE: redefinition-problem-2 ;
|
|||
|
||||
[ ] [
|
||||
[
|
||||
\ vocab tuple { "xxx" } "slots" get append
|
||||
\ vocab identity-tuple { "xxx" } "slots" get append
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
|
||||
all-words drop
|
||||
|
||||
[
|
||||
\ vocab tuple "slots" get
|
||||
\ vocab identity-tuple "slots" get
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
@ -765,3 +765,22 @@ USE: classes.struct
|
|||
[ "prototype" word-prop ] map
|
||||
[ '[ _ hashcode drop f ] [ drop t ] recover ] filter
|
||||
] unit-test
|
||||
|
||||
! Make sure that tuple reshaping updates code heap roots
|
||||
TUPLE: code-heap-ref ;
|
||||
|
||||
: code-heap-ref' ( -- a ) T{ code-heap-ref } ;
|
||||
|
||||
! Push foo's literal to tenured space
|
||||
[ ] [ gc ] unit-test
|
||||
|
||||
! Reshape!
|
||||
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
|
||||
|
||||
! Code heap reference
|
||||
[ t ] [ code-heap-ref' code-heap-ref? ] unit-test
|
||||
[ 5 ] [ code-heap-ref' x>> ] unit-test
|
||||
|
||||
! Data heap reference
|
||||
[ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
|
||||
[ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
|
||||
|
|
|
@ -64,16 +64,6 @@ M: f process-forgotten-words drop ;
|
|||
: without-optimizer ( quot -- )
|
||||
[ f compiler-impl ] dip with-variable ; inline
|
||||
|
||||
! Trivial compiler. We don't want to touch the code heap
|
||||
! during stage1 bootstrap, it would just waste time.
|
||||
SINGLETON: dummy-compiler
|
||||
|
||||
M: dummy-compiler to-recompile f ;
|
||||
|
||||
M: dummy-compiler recompile drop { } ;
|
||||
|
||||
M: dummy-compiler process-forgotten-words drop ;
|
||||
|
||||
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
|
||||
|
||||
SYMBOL: definition-observers
|
||||
|
@ -143,13 +133,15 @@ M: object bump-effect-counter* drop f ;
|
|||
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
|
||||
|
||||
: finish-compilation-unit ( -- )
|
||||
[ ] [
|
||||
remake-generics
|
||||
to-recompile recompile
|
||||
update-tuples
|
||||
process-forgotten-definitions
|
||||
modify-code-heap
|
||||
bump-effect-counter
|
||||
notify-observers ;
|
||||
notify-observers
|
||||
] if-bootstrapping ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -282,3 +282,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
|
|||
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
|
||||
[ error>> bad-dispatch-position? ]
|
||||
must-fail-with
|
||||
|
||||
[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
|
||||
[ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes classes.algebra
|
||||
combinators definitions generic hashtables kernel
|
||||
|
@ -16,6 +16,8 @@ TUPLE: single-combination ;
|
|||
PREDICATE: single-generic < generic
|
||||
"combination" word-prop single-combination? ;
|
||||
|
||||
M: single-generic make-inline cannot-be-inline ;
|
||||
|
||||
GENERIC: dispatch# ( word -- n )
|
||||
|
||||
M: generic dispatch# "combination" word-prop dispatch# ;
|
||||
|
|
|
@ -111,11 +111,10 @@ SYMBOL: bootstrap-syntax
|
|||
|
||||
: with-file-vocabs ( quot -- )
|
||||
[
|
||||
<manifest> manifest set
|
||||
"syntax" use-vocab
|
||||
bootstrap-syntax get [ use-words ] when*
|
||||
call
|
||||
] with-scope ; inline
|
||||
] with-manifest ; inline
|
||||
|
||||
SYMBOL: print-use-hook
|
||||
|
||||
|
|
|
@ -16,7 +16,8 @@ checksum
|
|||
definitions ;
|
||||
|
||||
: record-top-level-form ( quot file -- )
|
||||
(>>top-level-form) H{ } notify-definition-observers ;
|
||||
(>>top-level-form)
|
||||
[ ] [ H{ } notify-definition-observers ] if-bootstrapping ;
|
||||
|
||||
: record-checksum ( lines source-file -- )
|
||||
[ crc32 checksum-lines ] dip (>>checksum) ;
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
IN: vocabs.parser.tests
|
||||
USING: vocabs.parser tools.test eval kernel accessors ;
|
||||
USING: vocabs.parser tools.test eval kernel accessors definitions
|
||||
compiler.units words vocabs ;
|
||||
|
||||
[ "FROM: kernel => doesnotexist ;" eval( -- ) ]
|
||||
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
|
||||
|
@ -8,3 +9,43 @@ must-fail-with
|
|||
[ "RENAME: doesnotexist kernel => newname" eval( -- ) ]
|
||||
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
|
||||
must-fail-with
|
||||
|
||||
: aaa ( -- ) ;
|
||||
|
||||
[
|
||||
[ ] [ "aaa" "vocabs.parser.tests" "uutt" add-renamed-word ] unit-test
|
||||
|
||||
[ ] [ "vocabs.parser.tests" dup add-qualified ] unit-test
|
||||
|
||||
[ aaa ] [ "uutt" search ] unit-test
|
||||
[ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test
|
||||
|
||||
[ ] [ [ "bbb" "vocabs.parser.tests" create drop ] with-compilation-unit ] unit-test
|
||||
|
||||
[ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test
|
||||
|
||||
[ ] [ [ \ aaa forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ [ "bbb" "vocabs.parser.tests" lookup forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ f ] [ "uutt" search ] unit-test
|
||||
|
||||
[ f ] [ "vocabs.parser.tests:aaa" search ] unit-test
|
||||
|
||||
[ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test
|
||||
|
||||
[ ] [ [ "bbb" current-vocab create drop ] with-compilation-unit ] unit-test
|
||||
|
||||
[ t ] [ "bbb" search >boolean ] unit-test
|
||||
|
||||
[ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test
|
||||
|
||||
[ [ "bbb" current-vocab create drop ] with-compilation-unit ] [ error>> no-current-vocab? ] must-fail-with
|
||||
|
||||
[ begin-private ] [ error>> no-current-vocab? ] must-fail-with
|
||||
|
||||
[ end-private ] [ error>> no-current-vocab? ] must-fail-with
|
||||
|
||||
[ f ] [ "bbb" search >boolean ] unit-test
|
||||
|
||||
] with-manifest
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
|
||||
! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs hashtables kernel namespaces sequences
|
||||
sets strings vocabs sorting accessors arrays compiler.units
|
||||
combinators vectors splitting continuations math
|
||||
combinators vectors splitting continuations math words
|
||||
parser.notes ;
|
||||
IN: vocabs.parser
|
||||
|
||||
|
@ -26,7 +26,6 @@ current-vocab
|
|||
{ search-vocab-names hashtable }
|
||||
{ search-vocabs vector }
|
||||
{ qualified-vocabs vector }
|
||||
{ extra-words vector }
|
||||
{ auto-used vector } ;
|
||||
|
||||
: <manifest> ( -- manifest )
|
||||
|
@ -34,7 +33,6 @@ current-vocab
|
|||
H{ } clone >>search-vocab-names
|
||||
V{ } clone >>search-vocabs
|
||||
V{ } clone >>qualified-vocabs
|
||||
V{ } clone >>extra-words
|
||||
V{ } clone >>auto-used ;
|
||||
|
||||
M: manifest clone
|
||||
|
@ -42,7 +40,6 @@ M: manifest clone
|
|||
[ clone ] change-search-vocab-names
|
||||
[ clone ] change-search-vocabs
|
||||
[ clone ] change-qualified-vocabs
|
||||
[ clone ] change-extra-words
|
||||
[ clone ] change-auto-used ;
|
||||
|
||||
TUPLE: extra-words words ;
|
||||
|
@ -69,10 +66,16 @@ ERROR: no-word-in-vocab word vocab ;
|
|||
: (from) ( vocab words -- vocab words words' vocab )
|
||||
2dup swap load-vocab ;
|
||||
|
||||
: extract-words ( seq vocab -- assoc' )
|
||||
: extract-words ( seq vocab -- assoc )
|
||||
[ words>> extract-keys dup ] [ name>> ] bi
|
||||
[ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
|
||||
|
||||
: excluding-words ( seq vocab -- assoc )
|
||||
[ nip words>> ] [ extract-words ] 2bi assoc-diff ;
|
||||
|
||||
: qualified-words ( prefix vocab -- assoc )
|
||||
words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
|
||||
|
||||
: (lookup) ( name assoc -- word/f )
|
||||
at dup forward-reference? [ drop f ] when ;
|
||||
|
||||
|
@ -83,8 +86,7 @@ PRIVATE>
|
|||
|
||||
: set-current-vocab ( name -- )
|
||||
create-vocab
|
||||
[ manifest get (>>current-vocab) ]
|
||||
[ words>> <extra-words> (add-qualified) ] bi ;
|
||||
[ manifest get (>>current-vocab) ] [ (add-qualified) ] bi ;
|
||||
|
||||
: with-current-vocab ( name quot -- )
|
||||
manifest get clone manifest [
|
||||
|
@ -102,11 +104,11 @@ TUPLE: no-current-vocab ;
|
|||
manifest get current-vocab>> [ no-current-vocab ] unless* ;
|
||||
|
||||
: begin-private ( -- )
|
||||
manifest get current-vocab>> vocab-name ".private" ?tail
|
||||
current-vocab name>> ".private" ?tail
|
||||
[ drop ] [ ".private" append set-current-vocab ] if ;
|
||||
|
||||
: end-private ( -- )
|
||||
manifest get current-vocab>> vocab-name ".private" ?tail
|
||||
current-vocab name>> ".private" ?tail
|
||||
[ set-current-vocab ] [ drop ] if ;
|
||||
|
||||
: using-vocab? ( vocab -- ? )
|
||||
|
@ -137,10 +139,7 @@ TUPLE: no-current-vocab ;
|
|||
TUPLE: qualified vocab prefix words ;
|
||||
|
||||
: <qualified> ( vocab prefix -- qualified )
|
||||
2dup
|
||||
[ load-vocab words>> ] [ CHAR: : suffix ] bi*
|
||||
[ swap [ prepend ] dip ] curry assoc-map
|
||||
qualified boa ;
|
||||
(from) qualified-words qualified boa ;
|
||||
|
||||
: add-qualified ( vocab prefix -- )
|
||||
<qualified> (add-qualified) ;
|
||||
|
@ -156,7 +155,7 @@ TUPLE: from vocab names words ;
|
|||
TUPLE: exclude vocab names words ;
|
||||
|
||||
: <exclude> ( vocab words -- from )
|
||||
(from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
|
||||
(from) excluding-words exclude boa ;
|
||||
|
||||
: add-words-excluding ( vocab words -- )
|
||||
<exclude> (add-qualified) ;
|
||||
|
@ -207,3 +206,45 @@ PRIVATE>
|
|||
|
||||
: search ( name -- word/f )
|
||||
manifest get search-manifest ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: update ( search-path-elt -- valid? )
|
||||
|
||||
: trim-forgotten ( qualified-vocab -- valid? )
|
||||
[ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
|
||||
words>> assoc-empty? not ;
|
||||
|
||||
M: from update trim-forgotten ;
|
||||
M: rename update trim-forgotten ;
|
||||
M: extra-words update trim-forgotten ;
|
||||
M: exclude update trim-forgotten ;
|
||||
|
||||
M: qualified update
|
||||
dup vocab>> vocab [
|
||||
dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
|
||||
>>words
|
||||
] [ drop f ] if ;
|
||||
|
||||
M: vocab update dup name>> vocab eq? ;
|
||||
|
||||
: update-manifest ( manifest -- )
|
||||
[ dup [ name>> vocab ] when ] change-current-vocab
|
||||
[ [ drop vocab ] assoc-filter ] change-search-vocab-names
|
||||
dup search-vocab-names>> keys [ vocab ] V{ } map-as >>search-vocabs
|
||||
qualified-vocabs>> [ update ] filter! drop ;
|
||||
|
||||
M: manifest definitions-changed ( assoc manifest -- )
|
||||
nip update-manifest ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-manifest ( quot -- )
|
||||
<manifest> manifest [
|
||||
[ call ] [
|
||||
[ manifest get add-definition-observer call ]
|
||||
[ manifest get remove-definition-observer ]
|
||||
[ ]
|
||||
cleanup
|
||||
] if-bootstrapping
|
||||
] with-variable ; inline
|
||||
|
|
|
@ -87,7 +87,11 @@ M: word subwords drop f ;
|
|||
: make-deprecated ( word -- )
|
||||
t "deprecated" set-word-prop ;
|
||||
|
||||
: make-inline ( word -- )
|
||||
ERROR: cannot-be-inline word ;
|
||||
|
||||
GENERIC: make-inline ( word -- )
|
||||
|
||||
M: word make-inline
|
||||
dup inline? [ drop ] [
|
||||
[ t "inline" set-word-prop ]
|
||||
[ changed-effect ]
|
||||
|
@ -155,7 +159,12 @@ ERROR: bad-create name vocab ;
|
|||
|
||||
: create ( name vocab -- word )
|
||||
check-create 2dup lookup
|
||||
dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
|
||||
dup [ 2nip ] [
|
||||
drop
|
||||
vocab-name <word>
|
||||
dup reveal
|
||||
dup changed-definition
|
||||
] if ;
|
||||
|
||||
: constructor-word ( name vocab -- word )
|
||||
[ "<" ">" surround ] dip create ;
|
||||
|
|
|
@ -110,6 +110,31 @@ struct object_become_visitor {
|
|||
}
|
||||
};
|
||||
|
||||
struct code_block_become_visitor {
|
||||
slot_visitor<slot_become_visitor> *workhorse;
|
||||
|
||||
explicit code_block_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
|
||||
workhorse(workhorse_) {}
|
||||
|
||||
void operator()(code_block *compiled, cell size)
|
||||
{
|
||||
workhorse->visit_code_block_objects(compiled);
|
||||
workhorse->visit_embedded_literals(compiled);
|
||||
}
|
||||
};
|
||||
|
||||
struct code_block_write_barrier_visitor {
|
||||
code_heap *code;
|
||||
|
||||
explicit code_block_write_barrier_visitor(code_heap *code_) :
|
||||
code(code_) {}
|
||||
|
||||
void operator()(code_block *compiled, cell size)
|
||||
{
|
||||
code->write_barrier(compiled);
|
||||
}
|
||||
};
|
||||
|
||||
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
|
||||
to coalesce equal but distinct quotations and wrappers. */
|
||||
void factor_vm::primitive_become()
|
||||
|
@ -134,6 +159,7 @@ void factor_vm::primitive_become()
|
|||
}
|
||||
|
||||
/* Update all references to old objects to point to new objects */
|
||||
{
|
||||
slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
|
||||
workhorse.visit_roots();
|
||||
workhorse.visit_contexts();
|
||||
|
@ -141,10 +167,18 @@ void factor_vm::primitive_become()
|
|||
object_become_visitor object_visitor(&workhorse);
|
||||
each_object(object_visitor);
|
||||
|
||||
code_block_become_visitor code_block_visitor(&workhorse);
|
||||
each_code_block(code_block_visitor);
|
||||
}
|
||||
|
||||
/* Since we may have introduced old->new references, need to revisit
|
||||
all objects on a minor GC. */
|
||||
all objects and code blocks on a minor GC. */
|
||||
data->mark_all_cards();
|
||||
primitive_minor_gc();
|
||||
|
||||
{
|
||||
code_block_write_barrier_visitor code_block_visitor(code);
|
||||
each_code_block(code_block_visitor);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue