steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Parser, definitions, source-files refactoring work in progress

db4
Slava Pestov 2007-12-21 21:18:24 -05:00
parent 6636a75a8a
commit 07a4022d62
43 changed files with 436 additions and 499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
core/bootstrap/compiler/compiler.factor
View File

@ -7,8 +7,6 @@ generator command-line vocabs io prettyprint libc ;
"cpu." cpu append require
global [ { "compiler" } add-use ] bind
"-no-stack-traces" cli-args member? [
f compiled-stack-traces? set-global
0 profiler-prologue set-global
@ -38,16 +36,22 @@ global [ { "compiler" } add-use ] bind
find-pair-next namestack*
bitand bitor bitxor bitnot
} compile-batch
} compile
{
+ 1+ 1- 2/ < <= > >= shift min
} compile
{
new nth push pop peek hashcode* = get set
} compile
{
. lines
} compile
{
malloc free memcpy
} [ compile ] each
} compile
[ recompile ] parse-hook set-global
[ compile-batch ] recompile-hook set-global

2
core/bootstrap/image/image.factor
View File

@ -444,7 +444,7 @@ PRIVATE>
: make-image ( arch -- )
[
parse-hook off
[ drop ] recompile-hook set
prepare-image
begin-image
"resource:/core/bootstrap/stage1.factor" run-file

4
core/bootstrap/primitives.factor Normal file → Executable file
View File

@ -14,7 +14,6 @@ slots classes.union words.private ;
load-help? off
crossref off
changed-words off
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
@ -144,7 +143,6 @@ H{ } clone update-map set
{ "float>" "math.private" }
{ "float>=" "math.private" }
{ "<word>" "words" }
{ "update-xt" "words" }
{ "word-xt" "words" }
{ "drop" "kernel" }
{ "2drop" "kernel" }
@ -189,7 +187,7 @@ H{ } clone update-map set
{ "tag" "kernel.private" }
{ "cwd" "io.files" }
{ "cd" "io.files" }
{ "modify-code-heap" "generator" }
{ "modify-code-heap" "words.private" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
{ "dlclose" "alien" }

16
core/bootstrap/stage2.factor
View File

@ -19,8 +19,6 @@ IN: bootstrap.stage2
parse-command-line
all-words [ dup ] H{ } map>assoc changed-words set-global
"-no-crossref" cli-args member? [
"Cross-referencing..." print flush
H{ } clone crossref set-global
@ -40,20 +38,14 @@ IN: bootstrap.stage2
"listener" use+
] if
f parse-hook [
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each
] with-variable
do-parse-hook
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each
init-io
init-stdio
changed-words get clear-assoc
"compile-errors" "generator" lookup [
f swap set-global
] when*

2
core/bootstrap/syntax.factor
View File

@ -63,6 +63,8 @@ f swap set-vocab-source-loaded?
"{"
"}"
"CS{"
"<<"
">>"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol

6
core/classes/classes.factor Normal file → Executable file
View File

@ -277,3 +277,9 @@ M: object class type type>class ;
2 slot { word } declare ; inline
PRIVATE>
! A dummy
TUPLE: class-definition ;
: <class-definition> ( word -- defspec )
class-definition construct-delegate ;

5
core/compiler/compiler-docs.factor
View File

@ -7,7 +7,7 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
{ $subsection compile }
"The optimizing compiler can also compile a single quotation:"
{ $subsection compile-quot }
{ $subsection compile-1 }
{ $subsection compile-call }
"Three utility words for bulk compilation:"
{ $subsection compile-batch }
{ $subsection compile-vocabs }
@ -112,9 +112,6 @@ HELP: recompile
HELP: compile-all
{ $description "Recompiles all words." } ;
HELP: changed-words
{ $var-description "Global variable holding words which need to be recompiled. Implemented as a hashtable where a key equals its value. This hashtable is updated by " { $link define } " when words are redefined, and inspected and cleared by " { $link recompile } "." } ;
HELP: compile-begins
{ $values { "word" word } }
{ $description "Prints a message stating the word is being compiled, unless we are inside a " { $link compile-batch } "." } ;

38
core/compiler/compiler.factor
View File

@ -2,12 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend
generator debugger math.parser prettyprint words continuations
vocabs assocs alien.compiler dlists optimizer ;
vocabs assocs alien.compiler dlists optimizer definitions ;
IN: compiler
: finish-compilation-unit ( assoc -- )
[ swap add* ] { } assoc>map modify-code-heap ;
SYMBOL: compiler-hook
: compile-begins ( word -- )
@ -23,7 +20,7 @@ SYMBOL: compiler-hook
[ drop ] [
compiled-usage
[ "was-compiled" word-prop ] subset
[ dup changed-word queue-compile ] each
[ queue-compile ] each
] if ;
: save-effect ( word effect -- )
@ -37,44 +34,25 @@ SYMBOL: compiler-hook
dup word-dataflow optimize >r over dup r> generate
] [
print-error
dup update-xt dup unchanged-word f
dup f compiled-xts get set-at f
] recover
2dup ripple-up save-effect
] [ drop ] if ;
: with-compilation-unit ( quot -- )
: compile ( words -- )
[
<dlist> compile-queue set
H{ } clone compiled-xts set
call
[ queue-compile ] each
compile-queue get [ (compile) ] dlist-slurp
compiled-xts get finish-compilation-unit
] with-scope ; inline
: compile-batch ( words -- )
[ [ queue-compile ] each ] with-compilation-unit ;
: compile ( word -- )
[ queue-compile ] with-compilation-unit ;
: compile-vocabs ( seq -- )
[ words ] map concat compile-batch ;
: compile-quot ( quot -- word )
define-temp dup compile ;
[ gensym dup rot define-compound ] with-compilation-unit ;
: compile-1 ( quot -- )
: compile-call ( quot -- )
compile-quot execute ;
: recompile ( -- )
changed-words get [
dup keys compile-batch clear-assoc
] when* ;
: forget-errors ( seq -- )
[ f "no-effect" set-word-prop ] each ;
: compile-all ( -- )
all-words
dup forget-errors [ changed-word ] each
recompile ;
all-words compile-batch ;

6
core/compiler/test/redefine.factor
View File

@ -3,6 +3,12 @@ namespaces parser tools.test words kernel sequences arrays io
effects tools.test.inference ;
IN: temporary
[ t ] [
changed-words get assoc-size
[ ] define-temp drop
changed-words get assoc-size =
] unit-test
parse-hook get [
DEFER: foo \ foo reset-generic
DEFER: bar \ bar reset-generic

2
core/continuations/continuations-tests.factor Normal file → Executable file
View File

@ -41,7 +41,7 @@ IN: temporary
"!!! The following error is part of the test" print
[ [ "2 car" ] parse ] catch print-error
[ [ "2 car" ] eval ] catch print-error
[ f throw ] unit-test-fails

7
core/debugger/debugger.factor Normal file → Executable file
View File

@ -221,3 +221,10 @@ M: condition error-help drop f ;
M: assert summary drop "Assertion failed" ;
M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error.
"Re-definition of " write
redefine-error-def . ;
M: forward-error error.
"Forward reference to " write forward-error-word . ;

27
core/definitions/definitions-docs.factor Normal file → Executable file
View File

@ -82,3 +82,30 @@ HELP: delete-xref
{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." }
{ $notes "This word is called before a word is forgotten." }
{ $see-also forget } ;
HELP: redefine-error
{ $values { "definition" "a definition specifier" } }
{ $description "Throws a " { $link redefine-error } "." }
{ $error-description "Indicates that a single source file contains two definitions for the same artifact, one of which shadows the other. This is an error since it indicates a likely mistake, such as two words accidentally named the same by the developer; the error is restartable." } ;
HELP: redefinition?
{ $values { "definition" "a definition specifier" } { "?" "a boolean" } }
{ $description "Tests if this definition is already present in the current source file." }
$parsing-note ;
HELP: (save-location)
{ $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Saves the location of a definition and associates this definition with the current source file."
$nl
"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ;
HELP: old-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ;
HELP: new-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ;
HELP: forward-error
{ $values { "word" word } }
{ $description "Throws a " { $link forward-error } "." }
{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ;

36
core/definitions/definitions.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: definitions
USING: kernel sequences namespaces assocs graphs ;
USING: kernel sequences namespaces assocs graphs continuations ;
GENERIC: where ( defspec -- loc )
@ -43,3 +43,37 @@ M: object redefined* drop ;
: delete-xref ( defspec -- )
dup unxref crossref get delete-at ;
SYMBOL: changed-words
SYMBOL: old-definitions
SYMBOL: new-definitions
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
\ redefine-error construct-boa
{ { "Continue" t } } throw-restarts drop ;
: redefinition? ( definition -- ? )
new-definitions get key? ;
: (save-location) ( definition loc -- )
over redefinition? [ over redefine-error ] when
over set-where
dup new-definitions get set-at ;
TUPLE: forward-error word ;
: forward-error ( word -- )
\ forward-error construct-boa throw ;
SYMBOL: recompile-hook
: with-compilation-unit ( quot -- new-defs )
[
H{ } clone changed-words set
H{ } clone new-definitions set
old-definitions off
call
changed-words get keys recompile-hook get call
] with-scope ; inline

4
core/generator/generator-docs.factor
View File

@ -26,10 +26,6 @@ HELP: compiling?
{ $values { "word" word } { "?" "a boolean" } }
{ $description "Tests if a word is going to be or already is compiled." } ;
HELP: modify-code-heap ( array -- )
{ $values { "array" "an array of 6-element arrays having shape " { $snippet "{ word code labels rel words literals }" } } }
{ $description "Stores compiled code definitions in the code heap and updates words to point at those definitions." } ;
HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;

2
core/generator/generator.factor
View File

@ -17,7 +17,7 @@ SYMBOL: compiled-xts
f swap compiled-xts get set-at ;
: finish-compiling ( word literals words rel labels code -- )
6array swap dup unchanged-word compiled-xts get set-at ;
6array swap compiled-xts get set-at ;
: compiling? ( word -- ? )
{

2
core/generic/generic-tests.factor
View File

@ -120,7 +120,7 @@ TUPLE: delegating ;
[ t ] [ \ + math-generic? ] unit-test
[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
[ "SYMBOL: not-a-class C: not-a-class ;" eval ] unit-test-fails
! Test math-combination
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test

3
core/inference/inference.factor Normal file → Executable file
View File

@ -25,3 +25,6 @@ M: callable dataflow-with
V{ } like meta-d set
f infer-quot
] with-infer nip ;
: forget-errors ( seq -- )
[ f "no-effect" set-word-prop ] each ;

2
core/inference/known-words/known-words.factor Normal file → Executable file
View File

@ -344,8 +344,6 @@ t over set-effect-terminated?
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
\ <word> make-flushable
\ update-xt { word } { } <effect> "inferred-effect" set-word-prop
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
\ word-xt make-flushable

12
core/io/crc32/crc32.factor Normal file → Executable file
View File

@ -1,23 +1,19 @@
! Copyright (C) 2006 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences sequences.private namespaces
words io io.binary io.files io.streams.string quotations ;
words io io.binary io.files io.streams.string quotations
definitions ;
IN: io.crc32
: crc32-polynomial HEX: edb88320 ; inline
! Generate the table at load time and define a new word with it,
! instead of using a variable, so that the compiler can inline
! the call to nth-unsafe
DEFER: crc32-table inline
: crc32-table V{ } ; inline
\ crc32-table
256 [
8 [
dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
] times >bignum
] map
1quotation define-inline
] map 0 crc32-table copy
: (crc32) ( crc ch -- crc )
>bignum dupd bitxor

4
core/kernel/kernel-docs.factor Normal file → Executable file
View File

@ -552,3 +552,7 @@ $nl
"[ P ] [ Q ] [ ] while T"
}
"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
HELP: modify-code-heap ( array -- )
{ $values { "array" "an array of 6-element arrays having shape " { $snippet "{ word code labels rel words literals }" } } }
{ $description "Stores compiled code definitions in the code heap and updates words to point at those definitions." } ;

0
core/kernel/kernel.factor Normal file → Executable file
View File

32
core/listener/listener.factor
View File

@ -3,7 +3,7 @@
USING: arrays hashtables io kernel math memory namespaces
parser sequences strings io.styles io.streams.lines
io.streams.duplex vectors words generic system combinators
tuples continuations debugger ;
tuples continuations debugger definitions ;
IN: listener
SYMBOL: quit-flag
@ -12,31 +12,34 @@ SYMBOL: listener-hook
[ ] listener-hook set-global
GENERIC: parse-interactive ( stream -- quot/f )
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-interactive-step ( lines -- quot/f )
: read-quot-step ( lines -- quot/f )
[ parse-lines ] catch {
{ [ dup delegate unexpected-eof? ] [ 2drop f ] }
{ [ dup not ] [ drop ] }
{ [ t ] [ rethrow ] }
} cond ;
: parse-interactive-loop ( stream accum -- quot/f )
: read-quot-loop ( stream accum -- quot/f )
over stream-readln dup [
over push
dup parse-interactive-step dup
[ 2nip ] [ drop parse-interactive-loop ] if
dup read-quot-step dup
[ 2nip ] [ drop read-quot-loop ] if
] [
3drop f
] if ;
M: line-reader parse-interactive
[
V{ } clone parse-interactive-loop in get
] with-scope in set ;
M: line-reader stream-read-quot
V{ } clone read-quot-loop ;
M: duplex-stream parse-interactive
duplex-stream-in parse-interactive ;
M: duplex-stream stream-read-quot
duplex-stream-in stream-read-quot ;
: read-quot ( -- quot )
[
stdio get stream-read-quot in get
] with-compilation-unit in set ;
: bye ( -- ) quit-flag on ;
@ -46,10 +49,7 @@ M: duplex-stream parse-interactive
: listen ( -- )
listener-hook get call prompt.
[
stdio get parse-interactive
[ call ] [ bye ] if*
] try ;
[ read-quot [ call ] [ bye ] if* ] try ;
: until-quit ( -- )
quit-flag get

67
core/parser/parser-docs.factor
View File

@ -231,22 +231,6 @@ HELP: location
{ $values { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link (save-location) } "." } ;
HELP: redefine-error
{ $values { "definition" "a definition specifier" } }
{ $description "Throws a " { $link redefine-error } "." }
{ $error-description "Indicates that a single source file contains two definitions for the same artifact, one of which shadows the other. This is an error since it indicates a likely mistake, such as two words accidentally named the same by the developer; the error is restartable." } ;
HELP: redefinition?
{ $values { "definition" "a definition specifier" } { "?" "a boolean" } }
{ $description "Tests if this definition is already present in the current source file." }
$parsing-note ;
HELP: (save-location)
{ $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Saves the location of a definition and associates this definition with the current source file."
$nl
"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ;
HELP: save-location
{ $values { "definition" "a definition specifier" } }
{ $description "Saves the location of a definition and associates this definition with the current source file."
@ -264,15 +248,6 @@ HELP: next-line
{ $values { "lexer" lexer } }
{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ;
HELP: file
{ $var-description "Stores the " { $link source-file } " being parsed. The " { $link source-file-path } " of this object comes from the input parameter to " { $link parse-stream } "." } ;
HELP: old-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ;
HELP: new-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ;
HELP: parse-error
{ $error-description "Thrown when the parser encounters invalid input. A parse error wraps an underlying error and holds the file being parsed, line number, and column number." } ;
@ -417,11 +392,6 @@ HELP: search
{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, throws a " { $link no-word } " error. If the search path does not contain a word with this name but other vocabularies do, the error will have restarts offering to add vocabularies to the search path." }
$parsing-note ;
HELP: forward-error
{ $values { "word" word } }
{ $description "Throws a " { $link forward-error } "." }
{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ;
HELP: scan-word
{ $values { "word/number/f" "a word, number or " { $link f } } }
{ $description "Reads the next token from parser input. If the token is a valid number literal, it is converted to a number, otherwise the dictionary is searched for a word named by the token. Outputs " { $link f } " if the end of the input has been reached." }
@ -510,11 +480,6 @@ HELP: bootstrap-syntax
HELP: file-vocabs
{ $description "Installs the initial the vocabulary search path for parsing a file. This consists of the " { $snippet "syntax" } " vocabulary together with the " { $snippet "scratchpad" } " vocabulary." } ;
HELP: parse
{ $values { "str" string } { "quot" quotation } }
{ $description "Parses Factor source code from a string. The current vocabulary search path is used." }
{ $errors "Throws a parse error if the input is malformed." } ;
HELP: parse-fresh
{ $values { "lines" "a sequence of strings" } { "quot" quotation } }
{ $description "Parses Factor source code in a sequence of lines. The initial vocabulary search path is used (see " { $link file-vocabs } ")." }
@ -525,17 +490,6 @@ HELP: eval
{ $description "Parses Factor source code from a string, and calls the resulting quotation. The current vocabulary search path is used." }
{ $errors "Throws an error if the input is malformed, or if the quotation throws an error." } ;
HELP: parse-hook
{ $var-description "A quotation called by " { $link parse-stream } " after parsing the input stream. The default value recompiles new word definitions; see " { $link "recompile" } " for details." } ;
{ parse-hook do-parse-hook } related-words
HELP: start-parsing
{ $values { "stream" "an input stream" } { "name" "a pathname string" } }
{ $description "Prepares to parse a source file by reading the entire contents of the stream and setting some variables. The pathname identifies the stream for cross-referencing purposes." }
{ $errors "Throws an I/O error if there was an error reading from the stream." }
{ $notes "This is one of the factors of " { $link parse-stream } "." } ;
HELP: outside-usages
{ $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } }
{ $description "Outputs an association list mapping elements of " { $snippet "seq" } " to lists of usages which exclude the definitions in " { $snippet "seq" } " themselves." } ;
@ -551,18 +505,11 @@ HELP: smudged-usage
HELP: forget-smudged
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
HELP: record-definitions
{ $values { "file" source-file } }
{ $description "Records that all " { $link new-definitions } " were defined in " { $snippet "file" } "." } ;
HELP: finish-parsing
{ $values { "quot" "the quotation just parsed" } }
{ $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." }
{ $notes "This is one of the factors of " { $link parse-stream } "." } ;
HELP: undo-parsing
{ $description "Records information to the current " { $link file } " after an incomplete parse which ended with an error." } ;
HELP: parse-stream
{ $values { "stream" "an input stream" } { "name" "a file name for error reporting and cross-referencing" } { "quot" quotation } }
{ $description "Parses Factor source code read from the stream. The initial vocabulary search path is used." }
@ -582,20 +529,6 @@ HELP: ?run-file
{ $values { "path" "a pathname string" } }
{ $description "If the file exists, runs it with " { $link run-file } ", otherwise does nothing." } ;
HELP: reload
{ $values { "defspec" "a definition specifier" } }
{ $description "Reloads the source file containing the definition." }
{ $examples
"Reloading a word definition:"
{ $code "\\ foo reload" }
"A word's documentation:"
{ $code "\\ foo >link reload" }
"A method definition:"
{ $code "{ editor draw-gadget* } reload" }
"A help article:"
{ $code "\"handbook\" >link reload" }
} ;
HELP: bootstrap-file
{ $values { "path" "a pathname string" } }
{ $description "If bootstrapping, parses the source file and adds its top level form to the quotation being constructed with " { $link make } "; the bootstrap code uses this to build up a boot quotation to be run on image startup. If not bootstrapping, just runs the file normally." } ;

87
core/parser/parser-tests.factor Normal file → Executable file
View File

@ -19,46 +19,46 @@ IN: temporary
[ 6 CHAR: \s ]
[ 0 "\\u0020hello" next-char ] unit-test
[ [ 1 [ 2 [ 3 ] 4 ] 5 ] ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" parse ]
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
unit-test
[ [ t t f f ] ]
[ "t t f f" parse ]
[ t t f f ]
[ "t t f f" eval ]
unit-test
[ [ "hello world" ] ]
[ "\"hello world\"" parse ]
[ "hello world" ]
[ "\"hello world\"" eval ]
unit-test
[ [ "\n\r\t\\" ] ]
[ "\"\\n\\r\\t\\\\\"" parse ]
[ "\n\r\t\\" ]
[ "\"\\n\\r\\t\\\\\"" eval ]
unit-test
[ "hello world" ]
[
"IN: temporary : hello \"hello world\" ;"
parse call "USE: scratchpad hello" eval
eval "USE: temporary hello" eval
] unit-test
[ ]
[ "! This is a comment, people." parse call ]
[ "! This is a comment, people." eval ]
unit-test
! Test escapes
[ [ " " ] ]
[ "\"\\u0020\"" parse ]
[ " " ]
[ "\"\\u0020\"" eval ]
unit-test
[ [ "'" ] ]
[ "\"\\u0027\"" parse ]
[ "'" ]
[ "\"\\u0027\"" eval ]
unit-test
[ "\\u123" parse ] unit-test-fails
[ "\\u123" eval ] unit-test-fails
! Test EOL comments in multiline strings.
[ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test
[ word ] [ \ f class ] unit-test
@ -80,7 +80,7 @@ IN: temporary
[ \ baz "declared-effect" word-prop effect-terminated? ]
unit-test
[ [ ] ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" parse ] unit-test
[ ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
[ t ] [
"effect-parsing-test" "temporary" lookup
@ -90,7 +90,7 @@ IN: temporary
[ T{ effect f { "a" "b" } { "d" } f } ]
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
[ [ ] ] [ "IN: temporary : effect-parsing-test ;" parse ] unit-test
[ ] [ "IN: temporary : effect-parsing-test ;" eval ] unit-test
[ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
@ -100,12 +100,12 @@ IN: temporary
[ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails
! These should throw errors
[ "HEX: zzz" parse ] unit-test-fails
[ "OCT: 999" parse ] unit-test-fails
[ "BIN: --0" parse ] unit-test-fails
[ "HEX: zzz" eval ] unit-test-fails
[ "OCT: 999" eval ] unit-test-fails
[ "BIN: --0" eval ] unit-test-fails
[ f ] [
"IN: temporary : foo ; TUPLE: foo ;" parse drop
"IN: temporary : foo ; TUPLE: foo ;" eval
"foo" "temporary" lookup symbol?
] unit-test
@ -126,13 +126,13 @@ IN: temporary
"IN: temporary USING: math prettyprint ; : foo 2 2 + . ; parsing" eval
[ [ ] ] [ "USE: temporary foo" parse ] unit-test
[ ] [ "USE: temporary foo" eval ] unit-test
"IN: temporary USING: math prettyprint ; : foo 2 2 + . ;" eval
[ t ] [
"USE: temporary foo" parse
first "foo" "temporary" lookup eq?
"USE: temporary \\ foo" eval
"foo" "temporary" lookup eq?
] unit-test
! Test smudging
@ -323,12 +323,43 @@ IN: temporary
<string-reader> "removing-the-predicate" parse-stream
] catch [ redefine-error? ] is?
] unit-test
[ t ] [
[
"IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
] catch [ redefine-error? ] is?
] unit-test
[ ] [
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test"
<string-reader> "redefining-a-class-2" parse-stream drop
] unit-test
[ t ] [
[
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ redefine-error? ] is?
] unit-test
[ t ] [
[
"IN: temporary \\ class-fwd-test TUPLE: class-fwd-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ forward-error? ] is?
] unit-test
[ t ] [
[
"IN: temporary \\ class-fwd-test TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ forward-error? ] is?
] unit-test
] with-scope
[
: FILE file get parsed ; parsing
FILE file set
<< file get parsed >> file set
: ~a ;
: ~b ~a ;

119
core/parser/parser.factor
View File

@ -8,8 +8,6 @@ io.files io.streams.string io.streams.lines vocabs
source-files classes hashtables ;
IN: parser
SYMBOL: file
TUPLE: lexer text line column ;
: <lexer> ( text -- lexer ) 1 0 lexer construct-boa ;
@ -21,27 +19,6 @@ TUPLE: lexer text line column ;
file get lexer get lexer-line 2dup and
[ >r source-file-path r> 2array ] [ 2drop f ] if ;
SYMBOL: old-definitions
SYMBOL: new-definitions
TUPLE: redefine-error def ;
M: redefine-error error.
"Re-definition of " write
redefine-error-def . ;
: redefine-error ( definition -- )
\ redefine-error construct-boa
{ { "Continue" t } } throw-restarts drop ;
: redefinition? ( definition -- ? )
dup class? [ drop f ] [ new-definitions get key? ] if ;
: (save-location) ( definition loc -- )
over redefinition? [ over redefine-error ] when
over set-where
dup new-definitions get dup [ set-at ] [ 3drop ] if ;
: save-location ( definition -- )
location (save-location) ;
@ -119,7 +96,8 @@ M: lexer skip-word ( lexer -- )
TUPLE: bad-escape ;
: bad-escape ( -- * ) \ bad-escape construct-empty throw ;
: bad-escape ( -- * )
\ bad-escape construct-empty throw ;
M: bad-escape summary drop "Bad escape code" ;
@ -238,7 +216,9 @@ PREDICATE: unexpected unexpected-eof
: CREATE ( -- word ) scan create-in ;
: CREATE-CLASS ( -- word )
scan create-in dup predicate-word save-location ;
scan in get create
dup <class-definition> save-location
dup predicate-word save-location ;
: word-restarts ( possibilities -- restarts )
natural-sort [
@ -256,16 +236,12 @@ M: no-word summary
dup word-vocabulary (use+) ;
: forward-reference? ( word -- ? )
dup old-definitions get key?
swap new-definitions get key? not and ;
TUPLE: forward-error word ;
M: forward-error error.
"Forward reference to " write forward-error-word . ;
: forward-error ( word -- )
\ forward-error construct-boa throw ;
{
{ [ dup old-definitions get key? not ] [ f ] }
{ [ dup new-definitions get key? ] [ f ] }
{ [ dup <class-definition> new-definitions get key? ] [ f ] }
{ [ t ] [ t ] }
} cond nip ;
: check-forward ( str word -- word )
dup forward-reference? [
@ -284,12 +260,25 @@ M: forward-error error.
: scan-word ( -- word/number/f )
scan dup [ dup string>number [ ] [ search ] ?if ] when ;
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
\ staging-violation construct-boa throw ;
M: staging-violation summary
drop
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
dup new-definitions get key? [ staging-violation ] when
execute ;
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
{ [ dup parsing? ] [ nip execute t ] }
{ [ dup parsing? ] [ nip execute-parsing t ] }
{ [ t ] [ pick push drop t ] }
} cond ;
@ -361,10 +350,6 @@ SYMBOL: bootstrap-syntax
: parse-fresh ( lines -- quot )
[ file-vocabs parse-lines ] with-scope ;
SYMBOL: parse-hook
: do-parse-hook ( -- ) parse-hook get [ call ] when* ;
: parsing-file ( file -- )
"quiet" get [
drop
@ -372,15 +357,6 @@ SYMBOL: parse-hook
"Loading " write <pathname> . flush
] if ;
: start-parsing ( stream name -- )
H{ } clone new-definitions set
dup [
source-file
dup file set
source-file-definitions clone old-definitions set
] [ drop ] if
contents \ contents set ;
: smudged-usage-warning ( usages removed -- )
parser-notes? [
"Warning: the following definitions were removed from sources," print
@ -416,35 +392,22 @@ SYMBOL: parse-hook
smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
: record-definitions ( file -- )
new-definitions get swap set-source-file-definitions ;
: finish-parsing ( quot -- )
file get dup [
[ record-form ] keep
[ record-modified ] keep
[ \ contents get record-checksum ] keep
record-definitions
forget-smudged
] [
2drop
] if ;
: undo-parsing ( -- )
file get [
dup source-file-definitions new-definitions get union
swap set-source-file-definitions
] when* ;
: finish-parsing ( contents quot -- )
file get
[ record-form ] keep
[ record-modified ] keep
[ record-definitions ] keep
record-checksum ;
: parse-stream ( stream name -- quot )
[
[
start-parsing
\ contents get string-lines parse-fresh
dup finish-parsing
do-parse-hook
] [ ] [ undo-parsing ] cleanup
] with-scope ;
contents
dup string-lines parse-fresh
tuck finish-parsing
forget-smudged
] with-source-file
] with-compilation-unit ;
: parse-file-restarts ( file -- restarts )
"Load " swap " again" 3append t 2array 1array ;
@ -462,9 +425,6 @@ SYMBOL: parse-hook
: run-file ( file -- )
[ [ parse-file call ] keep ] assert-depth drop ;
: reload ( defspec -- )
where first [ run-file ] when* ;
: ?run-file ( path -- )
dup ?resource-path exists? [ run-file ] [ drop ] if ;
@ -478,9 +438,8 @@ SYMBOL: parse-hook
: ?bootstrap-file ( path -- )
dup ?resource-path exists? [ bootstrap-file ] [ drop ] if ;
: parse ( str -- quot ) string-lines parse-lines ;
: eval ( str -- ) parse call ;
: eval ( str -- )
[ string-lines parse-fresh ] with-compilation-unit call ;
: eval>string ( str -- output )
[

4
core/prettyprint/prettyprint-tests.factor
View File

@ -53,10 +53,6 @@ unit-test
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
[ t ] [
"[ >r \"alloc\" add 0 0 r> ]" dup parse first unparse =
] unit-test
[ ] [ \ fixnum see ] unit-test
[ ] [ \ integer see ] unit-test

11
core/source-files/source-files-docs.factor Normal file → Executable file
View File

@ -80,3 +80,14 @@ HELP: reset-checksums
HELP: forget-source
{ $values { "path" "a pathname string" } }
{ $description "Forgets all information known about a source file." } ;
HELP: record-definitions
{ $values { "file" source-file } }
{ $description "Records that all " { $link new-definitions } " were defined in " { $snippet "file" } "." } ;
HELP: rollback-source-file
{ $values { "file" source-file } }
{ $description "Records information to the source file after an incomplete parse which ended with an error." } ;
HELP: file
{ $var-description "Stores the " { $link source-file } " being parsed. The " { $link source-file-path } " of this object comes from the input parameter to " { $link with-source-file } "." } ;

22
core/source-files/source-files.factor Normal file → Executable file
View File

@ -33,8 +33,8 @@ uses definitions ;
dup source-file-path ?resource-path file-modified
swap set-source-file-modified ;
: record-checksum ( source-file contents -- )
crc32 swap set-source-file-checksum ;
: record-checksum ( contents source-file -- )
>r crc32 r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> swap source-file-uses
@ -54,6 +54,9 @@ uses definitions ;
swap quot-uses keys over set-source-file-uses
xref-source ;
: record-definitions ( file -- )
new-definitions get swap set-source-file-definitions ;
: <source-file> ( path -- source-file )
{ set-source-file-path } \ source-file construct ;
@ -75,3 +78,18 @@ M: pathname where pathname-string 1 2array ;
source-files get delete-at ;
M: pathname forget pathname-string forget-source ;
: rollback-source-file ( source-file -- )
dup source-file-definitions new-definitions get union
swap set-source-file-definitions ;
SYMBOL: file
: with-source-file ( name quot -- )
#! Should be called from inside with-compilation-unit.
[
swap source-file
dup file set
source-file-definitions old-definitions set
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline

220
core/syntax/syntax.factor
View File

@ -22,145 +22,149 @@ IN: bootstrap.syntax
>r "syntax" lookup dup r> define-compound
t "parsing" set-word-prop ;
{ "]" "}" ";" } [ define-delimiter ] each
[
{ "]" "}" ";" ">>" } [ define-delimiter ] each
"PRIMITIVE:" [
"Primitive definition is not supported" throw
] define-syntax
"PRIMITIVE:" [
"Primitive definition is not supported" throw
] define-syntax
"CS{" [
"Call stack literals are not supported" throw
] define-syntax
"CS{" [
"Call stack literals are not supported" throw
] define-syntax
"!" [ lexer get next-line ] define-syntax
"!" [ lexer get next-line ] define-syntax
"#!" [ POSTPONE: ! ] define-syntax
"#!" [ POSTPONE: ! ] define-syntax
"IN:" [ scan set-in ] define-syntax
"IN:" [ scan set-in ] define-syntax
"PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
"PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
"<PRIVATE" [
POSTPONE: PRIVATE> in get ".private" append set-in
] define-syntax
"<PRIVATE" [
POSTPONE: PRIVATE> in get ".private" append set-in
] define-syntax
"USE:" [ scan use+ ] define-syntax
"USE:" [ scan use+ ] define-syntax
"USE-IF:" [
scan-word scan swap execute [ use+ ] [ drop ] if
] define-syntax
"USE-IF:" [
scan-word scan swap execute [ use+ ] [ drop ] if
] define-syntax
"USING:" [ ";" parse-tokens add-use ] define-syntax
"USING:" [ ";" parse-tokens add-use ] define-syntax
"HEX:" [ 16 parse-base ] define-syntax
"OCT:" [ 8 parse-base ] define-syntax
"BIN:" [ 2 parse-base ] define-syntax
"HEX:" [ 16 parse-base ] define-syntax
"OCT:" [ 8 parse-base ] define-syntax
"BIN:" [ 2 parse-base ] define-syntax
"f" [ f parsed ] define-syntax
"t" "syntax" lookup define-symbol
"f" [ f parsed ] define-syntax
"t" "syntax" lookup define-symbol
"CHAR:" [ 0 scan next-char nip parsed ] define-syntax
"\"" [ parse-string parsed ] define-syntax
"CHAR:" [ 0 scan next-char nip parsed ] define-syntax
"\"" [ parse-string parsed ] define-syntax
"SBUF\"" [
lexer get skip-blank parse-string >sbuf parsed
] define-syntax
"SBUF\"" [
lexer get skip-blank parse-string >sbuf parsed
] define-syntax
"P\"" [
lexer get skip-blank parse-string <pathname> parsed
] define-syntax
"P\"" [
lexer get skip-blank parse-string <pathname> parsed
] define-syntax
"[" [ \ ] [ >quotation ] parse-literal ] define-syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
"[" [ \ ] [ >quotation ] parse-literal ] define-syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
"POSTPONE:" [ scan-word parsed ] define-syntax
"\\" [ scan-word literalize parsed ] define-syntax
"inline" [ word make-inline ] define-syntax
"foldable" [ word make-foldable ] define-syntax
"flushable" [ word make-flushable ] define-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-syntax
"parsing" [ word t "parsing" set-word-prop ] define-syntax
"POSTPONE:" [ scan-word parsed ] define-syntax
"\\" [ scan-word literalize parsed ] define-syntax
"inline" [ word make-inline ] define-syntax
"foldable" [ word make-foldable ] define-syntax
"flushable" [ word make-flushable ] define-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-syntax
"parsing" [ word t "parsing" set-word-prop ] define-syntax
"SYMBOL:" [
CREATE dup reset-generic define-symbol
] define-syntax
"SYMBOL:" [
CREATE dup reset-generic define-symbol
] define-syntax
"DEFER:" [
scan in get create
dup old-definitions get delete-at
set-word
] define-syntax
"DEFER:" [
scan in get create
dup old-definitions get delete-at
set-word
] define-syntax
":" [
CREATE dup reset-generic parse-definition define-compound
] define-syntax
":" [
CREATE dup reset-generic parse-definition define-compound
] define-syntax
"GENERIC:" [
CREATE dup reset-word
define-simple-generic
] define-syntax
"GENERIC:" [
CREATE dup reset-word
define-simple-generic
] define-syntax
"GENERIC#" [
CREATE dup reset-word
scan-word <standard-combination> define-generic
] define-syntax
"GENERIC#" [
CREATE dup reset-word
scan-word <standard-combination> define-generic
] define-syntax
"MATH:" [
CREATE dup reset-word
T{ math-combination } define-generic
] define-syntax
"MATH:" [
CREATE dup reset-word
T{ math-combination } define-generic
] define-syntax
"HOOK:" [
CREATE dup reset-word scan-word
<hook-combination> define-generic
] define-syntax
"HOOK:" [
CREATE dup reset-word scan-word
<hook-combination> define-generic
] define-syntax
"M:" [
f set-word
location >r
scan-word bootstrap-word scan-word
[ parse-definition <method> -rot define-method ] 2keep
2array r> (save-location)
] define-syntax
"M:" [
f set-word
location >r
scan-word bootstrap-word scan-word
[ parse-definition <method> -rot define-method ] 2keep
2array r> (save-location)
] define-syntax
"UNION:" [
CREATE-CLASS parse-definition define-union-class
] define-syntax
"UNION:" [
CREATE-CLASS parse-definition define-union-class
] define-syntax
"MIXIN:" [
CREATE-CLASS define-mixin-class
] define-syntax
"MIXIN:" [
CREATE-CLASS define-mixin-class
] define-syntax
"INSTANCE:" [ scan-word scan-word add-mixin-instance ] define-syntax
"INSTANCE:" [ scan-word scan-word add-mixin-instance ] define-syntax
"PREDICATE:" [
scan-word
CREATE-CLASS
parse-definition define-predicate-class
] define-syntax
"PREDICATE:" [
scan-word
CREATE-CLASS
parse-definition define-predicate-class
] define-syntax
"TUPLE:" [
CREATE-CLASS ";" parse-tokens define-tuple-class
] define-syntax
"TUPLE:" [
CREATE-CLASS ";" parse-tokens define-tuple-class
] define-syntax
"C:" [
CREATE dup reset-generic
scan-word dup check-tuple
[ construct-boa ] curry define-inline
] define-syntax
"C:" [
CREATE dup reset-generic
scan-word dup check-tuple
[ construct-boa ] curry define-inline
] define-syntax
"FORGET:" [ scan use get assoc-stack forget ] define-syntax
"FORGET:" [ scan use get assoc-stack forget ] define-syntax
"(" [
parse-effect word
[ swap "declared-effect" set-word-prop ] [ drop ] if*
] define-syntax
"(" [
parse-effect word
[ swap "declared-effect" set-word-prop ] [ drop ] if*
] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [ \ >> parse-until >quotation call ] define-syntax
] with-compilation-unit

31
core/words/words-docs.factor Normal file → Executable file
View File

@ -143,8 +143,7 @@ ARTICLE: "word.private" "Word implementation details"
{ $subsection word-def }
{ $subsection set-word-def }
"An " { $emphasis "XT" } " (execution token) is the machine code address of a word:"
{ $subsection word-xt }
{ $subsection update-xt } ;
{ $subsection word-xt } ;
ARTICLE: "words" "Words"
"Words are the Factor equivalent of functions or procedures; a word is a body of code with a unique name and some additional meta-data. Words are defined in the " { $vocab-link "words" } " vocabulary."
@ -278,15 +277,6 @@ HELP: gensym
{ $examples { $unchecked-example "gensym ." "G:260561" } }
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
HELP: define-temp
{ $values { "quot" quotation } { "word" word } }
{ $description "Creates an uninterned word that will call " { $snippet "quot" } " when executed." }
{ $notes
"The following phrases are equivalent:"
{ $code "[ 2 2 + . ] call" }
{ $code "[ 2 2 + . ] define-temp execute" }
} ;
HELP: bootstrapping?
{ $var-description "Set by the library while bootstrap is in progress. Some parsing words need to behave differently during bootstrap." } ;
@ -337,30 +327,11 @@ HELP: bootstrap-word
{ $values { "word" word } { "target" word } }
{ $description "Looks up a word with the same name and vocabulary as the given word, performing a transformation to handle parsing words in the target dictionary. Used during bootstrap to transfer host words to the target dictionary." } ;
HELP: update-xt ( word -- )
{ $values { "word" word } }
{ $description "Updates a word's execution token based on the value of the " { $link word-def } " slot. If the word was compiled by the optimizing compiler, this forces the word to revert to its unoptimized definition." }
{ $side-effects "word" } ;
HELP: parsing?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is a parsing word declared by " { $link POSTPONE: parsing } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
HELP: word-changed?
{ $values { "word" word } { "?" "a boolean" } }
{ $description "Tests if a word needs to be recompiled." } ;
HELP: changed-word
{ $values { "word" word } }
{ $description "Marks a word as needing recompilation by adding it to the " { $link changed-words } " assoc." }
$low-level-note ;
HELP: unchanged-word
{ $values { "word" word } }
{ $description "Marks a word as no longer needing recompilation by removing it from the " { $link changed-words } " assoc." }
$low-level-note ;
HELP: define-declared
{ $values { "word" word } { "def" quotation } { "effect" effect } }
{ $description "Defines a compound word and declares its stack effect." }

6
core/words/words-tests.factor Normal file → Executable file
View File

@ -126,12 +126,6 @@ DEFER: x
[ ] [ "IN: temporary : test-last ( -- ) ;" eval ] unit-test
[ "test-last" ] [ word word-name ] unit-test
[ t ] [
changed-words get assoc-size
[ ] define-temp drop
changed-words get assoc-size =
] unit-test
! regression
SYMBOL: quot-uses-a
SYMBOL: quot-uses-b

39
core/words/words.factor Normal file → Executable file
View File

@ -14,18 +14,6 @@ GENERIC: execute ( word -- )
M: word execute (execute) ;
! Used by the compiler
SYMBOL: changed-words
: word-changed? ( word -- ? )
changed-words get [ key? ] [ drop f ] if* ;
: changed-word ( word -- )
dup changed-words get [ set-at ] [ 2drop ] if* ;
: unchanged-word ( word -- )
changed-words get [ delete-at ] [ drop ] if* ;
M: word <=>
[ dup word-name swap word-vocabulary 2array ] compare ;
@ -98,21 +86,14 @@ M: compound redefined* ( word -- )
<PRIVATE
: definition-changed? ( word def -- ? )
swap word-def = not ;
: changed-word ( word -- ) dup changed-words get set-at ;
: define ( word def -- )
2dup definition-changed? [
over redefined
over unxref
over set-word-def
dup update-xt
dup word-vocabulary [
dup changed-word dup xref
] when drop
] [
2drop
] if ;
over unxref
over redefined
over set-word-def
dup changed-word
dup word-vocabulary [ dup xref ] when drop ;
PRIVATE>
@ -154,9 +135,6 @@ PRIVATE>
: gensym ( -- word )
"G:" \ gensym counter number>string append f <word> ;
: define-temp ( quot -- word )
gensym [ swap define-compound ] keep ;
: reveal ( word -- )
dup word-name over word-vocabulary vocab-words set-at ;
@ -201,7 +179,6 @@ M: word (forget-word)
: forget-word ( word -- )
dup delete-xref
dup unchanged-word
(forget-word) ;
M: word forget forget-word ;
@ -214,3 +191,7 @@ M: word literalize <wrapper> ;
: ?word-name dup word? [ word-name ] when ;
: xref-words ( -- ) all-words [ xref ] each ;
recompile-hook global
[ [ [ f ] { } map>assoc modify-code-heap ] or ]
change-at

2
extra/cocoa/cocoa.factor Normal file → Executable file
View File

@ -32,7 +32,7 @@ SYMBOL: super-sent-messages
{
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
} compile-vocabs
} [ words ] map concat compile-batch
"Importing Cocoa classes..." print
{

0
extra/cocoa/subclassing/subclassing.factor Normal file → Executable file
View File

12
extra/shuffle/shuffle-tests.factor Normal file → Executable file
View File

@ -1,25 +1,25 @@
USING: arrays shuffle kernel math tools.test compiler words ;
USING: arrays shuffle kernel math tools.test inference words ;
[ 8 ] [ 5 6 7 8 3nip ] unit-test
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test
{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test
{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test
{ t } [ [ 1 1 ndup ] compile-quot compiled? ] unit-test
{ t } [ [ 1 1 ndup ] infer >boolean ] unit-test
{ 1 1 } [ 1 1 ndup ] unit-test
{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test
{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test
{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test
{ t } [ [ 1 2 2 nrot ] compile-quot compiled? ] unit-test
{ t } [ [ 1 2 2 nrot ] infer >boolean ] unit-test
{ 2 1 } [ 1 2 2 nrot ] unit-test
{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test
{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test
{ t } [ [ 1 2 2 -nrot ] compile-quot compiled? ] unit-test
{ t } [ [ 1 2 2 -nrot ] infer >boolean ] unit-test
{ 2 1 } [ 1 2 2 -nrot ] unit-test
{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test
{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test
{ t } [ [ 1 2 3 4 3 nnip ] compile-quot compiled? ] unit-test
{ t } [ [ 1 2 3 4 3 nnip ] infer >boolean ] unit-test
{ 4 } [ 1 2 3 4 3 nnip ] unit-test
{ t } [ [ 1 2 3 4 4 ndrop ] compile-quot compiled? ] unit-test
{ t } [ [ 1 2 3 4 4 ndrop ] infer >boolean ] unit-test
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test

2
extra/tools/annotations/annotations-docs.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax words parser ;
IN: tools.annotations
ARTICLE: "tools.annotations" "Word annotations"
"The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reload } " on the word in question."
"The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question."
{ $subsection watch }
{ $subsection breakpoint }
{ $subsection breakpoint-if }

2
extra/tools/annotations/annotations.factor Normal file → Executable file
View File

@ -4,6 +4,8 @@ USING: kernel words parser io inspector quotations sequences
prettyprint continuations effects ;
IN: tools.annotations
: reset "not implemented yet" throw ;
: annotate ( word quot -- )
over >r >r word-def r> call r>
swap define-compound do-parse-hook ;

6
extra/tools/deploy/shaker/strip-cocoa.factor Normal file → Executable file
View File

@ -22,9 +22,5 @@ global [
! We need this for strip-stack-traces to work fully
{ message-senders super-message-senders }
[
get values [
dup update-xt compile
] each
] each
[ get values compile ] each
] bind

16
extra/ui/tools/operations/operations.factor
View File

@ -67,24 +67,14 @@ V{ } clone operations set-global
{ +listener+ t }
} define-operation
UNION: definition word method-spec link ;
UNION: definition word method-spec link vocab vocab-link ;
UNION: editable-definition definition vocab vocab-link ;
[ editable-definition? ] \ edit H{
[ definition? ] \ edit H{
{ +keyboard+ T{ key-down f { C+ } "E" } }
{ +listener+ t }
} define-operation
UNION: reloadable-definition definition pathname ;
[ reloadable-definition? ] \ reload H{
{ +keyboard+ T{ key-down f { C+ } "R" } }
{ +listener+ t }
} define-operation
[ dup reloadable-definition? swap vocab-spec? or ] \ forget
H{ } define-operation
[ definition? ] \ forget H{ } define-operation
! Words
[ word? ] \ insert-word H{

54
vm/code_heap.c
View File

@ -348,32 +348,44 @@ DEFINE_PRIMITIVE(modify_code_heap)
CELL i;
for(i = 0; i < count; i++)
{
F_ARRAY *data = untag_array(array_nth(alist,i));
F_ARRAY *pair = untag_array(array_nth(alist,i));
F_WORD *word = untag_word(array_nth(data,0));
CELL profiler_prologue = to_cell(array_nth(data,1));
F_ARRAY *literals = untag_array(array_nth(data,2));
F_ARRAY *words = untag_array(array_nth(data,3));
F_ARRAY *rel = untag_array(array_nth(data,4));
F_ARRAY *labels = untag_array(array_nth(data,5));
F_ARRAY *code = untag_array(array_nth(data,6));
F_WORD *word = untag_word(array_nth(pair,0));
CELL data = array_nth(pair,1);
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
if(data == F)
{
word->compiledp = F;
word->xt = default_word_xt(word);
}
else
{
F_ARRAY *compiled_code = untag_array(data);
F_COMPILED *compiled = add_compiled_block(
WORD_TYPE,
profiler_prologue,
code,
labels,
rel,
words,
literals);
CELL profiler_prologue = to_cell(array_nth(compiled_code,0));
F_ARRAY *literals = untag_array(array_nth(compiled_code,1));
F_ARRAY *words = untag_array(array_nth(compiled_code,2));
F_ARRAY *rel = untag_array(array_nth(compiled_code,3));
F_ARRAY *labels = untag_array(array_nth(compiled_code,4));
F_ARRAY *code = untag_array(array_nth(compiled_code,5));
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
set_word_xt(word,compiled);
F_COMPILED *compiled = add_compiled_block(
WORD_TYPE,
profiler_prologue,
code,
labels,
rel,
words,
literals);
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
set_word_xt(word,compiled);
}
}
if(count != 0)

1
vm/primitives.c Normal file → Executable file
View File

@ -67,7 +67,6 @@ void *primitives[] = {
primitive_float_greater,
primitive_float_greatereq,
primitive_word,
primitive_update_xt,
primitive_word_xt,
primitive_drop,
primitive_2drop,

7
vm/types.c
View File

@ -474,13 +474,6 @@ DEFINE_PRIMITIVE(word)
dpush(tag_object(allot_word(vocab,name)));
}
DEFINE_PRIMITIVE(update_xt)
{
F_WORD *word = untag_word(dpop());
word->compiledp = F;
word->xt = default_word_xt(word);
}
DEFINE_PRIMITIVE(word_xt)
{
F_WORD *word = untag_word(dpeek());

1
vm/types.h Normal file → Executable file
View File

@ -187,7 +187,6 @@ DECLARE_PRIMITIVE(hashtable);
F_WORD *allot_word(CELL vocab, CELL name);
DECLARE_PRIMITIVE(word);
DECLARE_PRIMITIVE(update_xt);
DECLARE_PRIMITIVE(word_xt);
DECLARE_PRIMITIVE(wrapper);