From 07a4022d621b03ad649153e461669c08b056cb8d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Dec 2007 21:18:24 -0500 Subject: [PATCH] Parser, definitions, source-files refactoring work in progress --- core/bootstrap/compiler/compiler.factor | 14 +- core/bootstrap/image/image.factor | 2 +- core/bootstrap/primitives.factor | 4 +- core/bootstrap/stage2.factor | 16 +- core/bootstrap/syntax.factor | 2 + core/classes/classes.factor | 6 + core/compiler/compiler-docs.factor | 5 +- core/compiler/compiler.factor | 38 +-- core/compiler/test/redefine.factor | 6 + core/continuations/continuations-tests.factor | 2 +- core/debugger/debugger.factor | 7 + core/definitions/definitions-docs.factor | 27 +++ core/definitions/definitions.factor | 36 ++- core/generator/generator-docs.factor | 4 - core/generator/generator.factor | 2 +- core/generic/generic-tests.factor | 2 +- core/inference/inference.factor | 3 + core/inference/known-words/known-words.factor | 2 - core/io/crc32/crc32.factor | 12 +- core/kernel/kernel-docs.factor | 4 + core/kernel/kernel.factor | 0 core/listener/listener.factor | 32 +-- core/parser/parser-docs.factor | 67 ------ core/parser/parser-tests.factor | 87 ++++--- core/parser/parser.factor | 119 ++++------ core/prettyprint/prettyprint-tests.factor | 4 - core/source-files/source-files-docs.factor | 11 + core/source-files/source-files.factor | 22 +- core/syntax/syntax.factor | 220 +++++++++--------- core/words/words-docs.factor | 31 +-- core/words/words-tests.factor | 6 - core/words/words.factor | 39 +--- extra/cocoa/cocoa.factor | 2 +- extra/cocoa/subclassing/subclassing.factor | 0 extra/shuffle/shuffle-tests.factor | 12 +- .../tools/annotations/annotations-docs.factor | 2 +- extra/tools/annotations/annotations.factor | 2 + extra/tools/deploy/shaker/strip-cocoa.factor | 6 +- extra/ui/tools/operations/operations.factor | 16 +- vm/code_heap.c | 54 +++-- vm/primitives.c | 1 - vm/types.c | 7 - vm/types.h | 1 - 43 files changed, 436 insertions(+), 499 deletions(-) mode change 100644 => 100755 core/bootstrap/primitives.factor mode change 100644 => 100755 core/classes/classes.factor mode change 100644 => 100755 core/continuations/continuations-tests.factor mode change 100644 => 100755 core/debugger/debugger.factor mode change 100644 => 100755 core/definitions/definitions-docs.factor mode change 100644 => 100755 core/definitions/definitions.factor mode change 100644 => 100755 core/inference/inference.factor mode change 100644 => 100755 core/inference/known-words/known-words.factor mode change 100644 => 100755 core/io/crc32/crc32.factor mode change 100644 => 100755 core/kernel/kernel-docs.factor mode change 100644 => 100755 core/kernel/kernel.factor mode change 100644 => 100755 core/parser/parser-tests.factor mode change 100644 => 100755 core/source-files/source-files-docs.factor mode change 100644 => 100755 core/source-files/source-files.factor mode change 100644 => 100755 core/words/words-docs.factor mode change 100644 => 100755 core/words/words-tests.factor mode change 100644 => 100755 core/words/words.factor mode change 100644 => 100755 extra/cocoa/cocoa.factor mode change 100644 => 100755 extra/cocoa/subclassing/subclassing.factor mode change 100644 => 100755 extra/shuffle/shuffle-tests.factor mode change 100644 => 100755 extra/tools/annotations/annotations-docs.factor mode change 100644 => 100755 extra/tools/annotations/annotations.factor mode change 100644 => 100755 extra/tools/deploy/shaker/strip-cocoa.factor mode change 100644 => 100755 vm/primitives.c mode change 100644 => 100755 vm/types.h diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 44c68d32f0..177632e49e 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -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 diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 4204503372..18efb74fa9 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor old mode 100644 new mode 100755 index 89c945656b..12248b8361 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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" } { "" "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" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3973af8bf4..ab491c72b0 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -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* diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 28d1dae9b6..8376b8771b 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -63,6 +63,8 @@ f swap set-vocab-source-loaded? "{" "}" "CS{" + "<<" + ">>" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/classes/classes.factor b/core/classes/classes.factor old mode 100644 new mode 100755 index d9f2c71f74..195ba23226 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -277,3 +277,9 @@ M: object class type type>class ; 2 slot { word } declare ; inline PRIVATE> + +! A dummy +TUPLE: class-definition ; + +: ( word -- defspec ) + class-definition construct-delegate ; diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 018336803e..6624e549de 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -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 } "." } ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 71fd4ab64b..8663ac5846 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -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 -- ) [ 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 ; diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 1fac112b2d..c54b09d0e8 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -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 diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor old mode 100644 new mode 100755 index 5ec6eedae9..d4a8cfb6a6 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -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 diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor old mode 100644 new mode 100755 index bdeeb0483b..be3393fbc2 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -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 . ; diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor old mode 100644 new mode 100755 index eeb547bb90..b771306d9b --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -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." } ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor old mode 100644 new mode 100755 index c9213c137b..d21d689975 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -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 diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index b5e3ef0f24..b77937205a 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -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 } "." } ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index aebc359bb9..0c63f74d64 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -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 -- ? ) { diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e780655156..76b9934586 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -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 diff --git a/core/inference/inference.factor b/core/inference/inference.factor old mode 100644 new mode 100755 index ff8af015c1..f89bfa85df --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -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 ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor old mode 100644 new mode 100755 index b1624a7650..97a426bb56 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -344,8 +344,6 @@ t over set-effect-terminated? \ { object object } { word } "inferred-effect" set-word-prop \ make-flushable -\ update-xt { word } { } "inferred-effect" set-word-prop - \ word-xt { word } { integer } "inferred-effect" set-word-prop \ word-xt make-flushable diff --git a/core/io/crc32/crc32.factor b/core/io/crc32/crc32.factor old mode 100644 new mode 100755 index 2b101945e7..53da1ed5a5 --- a/core/io/crc32/crc32.factor +++ b/core/io/crc32/crc32.factor @@ -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 diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor old mode 100644 new mode 100755 index 31d28a6ec6..af6acd004b --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor old mode 100644 new mode 100755 diff --git a/core/listener/listener.factor b/core/listener/listener.factor index f0ded202b0..709a03ee27 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -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 diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 2fd560943e..446add5678 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -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." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor old mode 100644 new mode 100755 index fe565aa254..521aef0577 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -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 "removing-the-predicate" parse-stream ] catch [ redefine-error? ] is? ] unit-test + + [ t ] [ + [ + "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "redefining-a-class-1" parse-stream + ] catch [ redefine-error? ] is? + ] unit-test + + [ ] [ + "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" + "redefining-a-class-2" parse-stream drop + ] unit-test + + [ t ] [ + [ + "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "redefining-a-class-3" parse-stream drop + ] catch [ redefine-error? ] is? + ] unit-test + + [ t ] [ + [ + "IN: temporary \\ class-fwd-test TUPLE: class-fwd-test ;" + "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" + "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 ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 8d1b488822..ca7c4199a8 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 ; : ( 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 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 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 . 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 ) [ diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index bb61251d28..7315b3f2e1 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -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 diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor old mode 100644 new mode 100755 index 48ace618f5..742d12fff3 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -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 } "." } ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor old mode 100644 new mode 100755 index 57ae7d7a53..30514e5aee --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -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 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 ; + : ( 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 diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 79840ac411..4c55dede64 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -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 -" in get ".private" append set-in -] define-syntax + " 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 parsed -] define-syntax + "P\"" [ + lexer get skip-blank parse-string 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 ] 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 ] 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 define-generic -] define-syntax + "GENERIC#" [ + CREATE dup reset-word + scan-word 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 - define-generic -] define-syntax + "HOOK:" [ + CREATE dup reset-word scan-word + define-generic + ] define-syntax -"M:" [ - f set-word - location >r - scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep - 2array r> (save-location) -] define-syntax + "M:" [ + f set-word + location >r + scan-word bootstrap-word scan-word + [ parse-definition -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 diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor old mode 100644 new mode 100755 index 08ca298d2c..520e7e00b4 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -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." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor old mode 100644 new mode 100755 index 85c6c81886..1a118fd705 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -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 diff --git a/core/words/words.factor b/core/words/words.factor old mode 100644 new mode 100755 index 2d91ef47a9..0491809cb6 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -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 -- ) @@ -154,9 +135,6 @@ PRIVATE> : gensym ( -- word ) "G:" \ gensym counter number>string append f ; -: 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 ; : ?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 diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor old mode 100644 new mode 100755 index f13a5e2ab0..60fb0c7e15 --- a/extra/cocoa/cocoa.factor +++ b/extra/cocoa/cocoa.factor @@ -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 { diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor old mode 100644 new mode 100755 diff --git a/extra/shuffle/shuffle-tests.factor b/extra/shuffle/shuffle-tests.factor old mode 100644 new mode 100755 index 165914e59c..9f2b8e01a9 --- a/extra/shuffle/shuffle-tests.factor +++ b/extra/shuffle/shuffle-tests.factor @@ -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 diff --git a/extra/tools/annotations/annotations-docs.factor b/extra/tools/annotations/annotations-docs.factor old mode 100644 new mode 100755 index e96728487a..affb95c761 --- a/extra/tools/annotations/annotations-docs.factor +++ b/extra/tools/annotations/annotations-docs.factor @@ -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 } diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor old mode 100644 new mode 100755 index e97f292416..87dd1ecd6b --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -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 ; diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor old mode 100644 new mode 100755 index 642999d6c2..2eddce6475 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -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 diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index b7a59f5c28..a65228db52 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -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{ diff --git a/vm/code_heap.c b/vm/code_heap.c index 049274af8a..2c125cd345 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -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) diff --git a/vm/primitives.c b/vm/primitives.c old mode 100644 new mode 100755 index 093af85f17..a70f7e4d95 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -67,7 +67,6 @@ void *primitives[] = { primitive_float_greater, primitive_float_greatereq, primitive_word, - primitive_update_xt, primitive_word_xt, primitive_drop, primitive_2drop, diff --git a/vm/types.c b/vm/types.c index 272625f000..6e465ba28d 100755 --- a/vm/types.c +++ b/vm/types.c @@ -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()); diff --git a/vm/types.h b/vm/types.h old mode 100644 new mode 100755 index 0d6f006cce..78c42d3a54 --- a/vm/types.h +++ b/vm/types.h @@ -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);