From 3824a33a5f20cb60b53d832afcf208e1681f2c72 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 12 Dec 2007 19:19:33 -0500 Subject: [PATCH 01/82] Windows release script fix --- misc/windows-release.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/windows-release.sh b/misc/windows-release.sh index 1f947ff3f4..7bd5f31814 100644 --- a/misc/windows-release.sh +++ b/misc/windows-release.sh @@ -6,7 +6,7 @@ if [ "$CPU" = "x86" ]; then FLAGS="-no-sse2" fi -make windows-nt-x86 +make windows-nt-x86-32 wget http://factorcode.org/dlls/freetype6.dll wget http://factorcode.org/dlls/zlib1.dll From c9646d20c5f1717f3987df61d62aeaca98e71593 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Dec 2007 15:17:28 -0500 Subject: [PATCH 02/82] Working on smarter recompilation --- core/alien/compiler/compiler.factor | 2 +- core/bootstrap/compiler/compiler.factor | 6 +- core/bootstrap/primitives.factor | 3 +- core/compiler/batch/batch.factor | 54 +++++++++++ core/compiler/compiler-docs.factor | 10 +-- core/compiler/compiler.factor | 22 ++--- core/cpu/architecture/architecture.factor | 3 +- core/cpu/arm/arm.factor | 2 +- core/cpu/ppc/architecture/architecture.factor | 2 +- core/cpu/ppc/ppc.factor | 2 +- core/cpu/x86/32/32.factor | 2 +- core/cpu/x86/64/64.factor | 2 +- core/generator/generator-docs.factor | 15 ++-- core/generator/generator.factor | 12 +-- core/words/words.factor | 1 - vm/code_gc.c | 27 +----- vm/code_heap.c | 89 +++++++++---------- vm/code_heap.h | 4 +- vm/image.c | 7 +- vm/layouts.h | 2 +- vm/primitives.c | 3 +- vm/profiler.c | 5 -- vm/profiler.h | 1 - vm/quotations.c | 2 +- vm/run.h | 1 - 25 files changed, 138 insertions(+), 141 deletions(-) create mode 100644 core/compiler/batch/batch.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 29957ac088..6ba63eeefc 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -387,7 +387,6 @@ TUPLE: callback-context ; : generate-callback ( node -- ) dup alien-callback-xt dup rot [ init-templates - generate-profiler-prologue %save-word-xt %prologue-later dup alien-stack-frame [ @@ -395,6 +394,7 @@ TUPLE: callback-context ; dup wrap-callback-quot %alien-callback %callback-return ] with-stack-frame + 0 ] generate-1 ; M: alien-callback generate-node diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 17e03c768f..4e06980bab 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -11,7 +11,7 @@ global [ { "compiler" } add-use ] bind "-no-stack-traces" cli-args member? [ f compiled-stack-traces? set-global - 0 set-profiler-prologues + 0 profiler-prologue set-global ] when ! Compile a set of words ahead of our general @@ -33,12 +33,14 @@ global [ { "compiler" } add-use ] bind delegate - underlying + underlying2 find-pair-next namestack* bitand bitor bitxor bitnot +} compile-batch +{ + 1+ 1- 2/ < <= > >= shift min new nth push pop peek hashcode* = get set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 297d49e696..89c945656b 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -189,7 +189,7 @@ H{ } clone update-map set { "tag" "kernel.private" } { "cwd" "io.files" } { "cd" "io.files" } - { "add-compiled-block" "generator" } + { "modify-code-heap" "generator" } { "dlopen" "alien" } { "dlsym" "alien" } { "dlclose" "alien" } @@ -243,7 +243,6 @@ H{ } clone update-map set { "end-scan" "memory" } { "size" "memory" } { "die" "kernel" } - { "finalize-compile" "generator" } { "fopen" "io.streams.c" } { "fgetc" "io.streams.c" } { "fread" "io.streams.c" } diff --git a/core/compiler/batch/batch.factor b/core/compiler/batch/batch.factor new file mode 100644 index 0000000000..3c725bbc9a --- /dev/null +++ b/core/compiler/batch/batch.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces dlists kernel words inference.backend +optimizer arrays definitions sequences assocs +continuations generator compiler ; +IN: compiler.batch + +! SYMBOL: compile-queue +! SYMBOL: compile-results +! +! TUPLE: compiled literals words rel labels code ; +! +! C: compiled +! +! : queue-compile ( word -- ) +! compile-queue get push-front ; +! +! : word-dataflow ( word -- effect dataflow ) +! [ +! dup "no-effect" word-prop [ no-effect ] when +! dup specialized-def over dup 2array 1array infer-quot +! finish-word +! ] with-infer ; +! +! : compiled-usage usage [ word? ] subset ; +! +! : ripple-up ( effect word -- ) +! tuck "compiled-effect" word-prop = +! [ drop ] [ compiled-usage [ queue-compile ] each ] if ; +! +! : save-effect ( effect word -- ) +! swap "compiled-effect" set-word-prop ; +! +! : add-compiled ( word -- ) +! >r f f f f f r> compile-results get set-at ; +! +! : compile-1 ( word -- ) +! dup compile-results get at [ drop ] [ +! [ [ word-dataflow drop ] [ 2drop f ] recover ] keep +! 2dup ripple-up +! tuck save-effect +! add-compiled +! ] if ; +! +! : compile-batch ( words -- ) +! [ +! compile-queue set +! [ queue-compile ] each +! H{ } clone compile-results set +! compile-queue get [ compile-1 ] dlist-slurp +! compile-results get +! ] with-scope ; + + diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 29744d31a6..ff82505102 100644 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -5,8 +5,6 @@ IN: compiler ARTICLE: "compiler-usage" "Calling the optimizing compiler" "The main entry point to the optimizing compiler is a single word taking a word as input:" { $subsection compile } -"The above word throws an error if the word did not compile. Another variant simply prints the error and returns:" -{ $subsection try-compile } "The optimizing compiler can also compile a single quotation:" { $subsection compile-quot } { $subsection compile-1 } @@ -76,18 +74,12 @@ $low-level-note ; HELP: compile { $values { "word" word } } -{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." } -{ $errors "If compilation fails, this word can throw an error. In particular, if the word's stack effect cannot be inferred, this word will throw an error. The related " { $link try-compile } " word logs errors and returns rather than throwing." } ; +{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." } ; HELP: compile-failed { $values { "word" word } { "error" "an error" } } { $description "Called when the optimizing compiler fails to compile a word. The word is removed from the set of words pending compilation, and it's un-optimized compiled definition will be used. The error is reported by calling " { $link compile-error } "." } ; -HELP: try-compile -{ $values { "word" word } } -{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." } -{ $errors "If compilation fails, this calls " { $link compile-failed } "." } ; - HELP: forget-errors { $values { "seq" "a sequence of words" } } { $description "If any of the words in the sequence previously failed to compile, removes the marker indicating such." diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index f80a00855d..cd6fb979f0 100644 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -14,12 +14,8 @@ M: object inference-error-major? drop t ; "quiet" get [ drop ] [ print-error flush ] if drop ] if ; -: begin-batch ( seq -- ) +: begin-batch ( -- ) batch-mode on - "quiet" get [ drop ] [ - [ "Compiling " % length # " words..." % ] "" make - print flush - ] if V{ } clone compile-errors set-global ; : compile-error. ( pair -- ) @@ -55,24 +51,30 @@ M: object inference-error-major? drop t ; : compile ( word -- ) H{ } clone [ compiled-xts [ (compile) ] with-variable - ] keep >alist finalize-compile ; + ] keep [ swap add* ] { } assoc>map modify-code-heap ; : compile-failed ( word error -- ) dupd compile-error dup update-xt unchanged-word ; -: try-compile ( word -- ) - [ compile ] [ compile-failed ] recover ; - : forget-errors ( seq -- ) [ f "no-effect" set-word-prop ] each ; +: (compile-batch) ( words -- ) + H{ } clone [ + compiled-xts [ + [ + [ (compile) ] [ compile-failed ] recover + ] each + ] with-variable + ] keep [ swap add* ] { } assoc>map modify-code-heap ; + : compile-batch ( seq -- ) dup empty? [ drop ] [ dup begin-batch dup forget-errors - [ try-compile ] each + (compile-batch) end-batch ] if ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 167014983e..538f17d2e0 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -5,8 +5,7 @@ namespaces sequences layouts system hashtables classes alien byte-arrays bit-arrays float-arrays combinators words ; IN: cpu.architecture -: set-profiler-prologues ( n -- ) - 39 setenv ; +SYMBOL: profiler-prologue SYMBOL: compiler-backend diff --git a/core/cpu/arm/arm.factor b/core/cpu/arm/arm.factor index f6d851e36b..2bad556f83 100755 --- a/core/cpu/arm/arm.factor +++ b/core/cpu/arm/arm.factor @@ -53,4 +53,4 @@ T{ arm-backend } compiler-backend set-global t have-BLX? set-global ] when -7 cells set-profiler-prologues +7 cells profiler-prologues set-global diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 28bfb8c09c..bb0e6cda62 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -134,7 +134,7 @@ M: ppc-backend %jump-t ( label -- ) "offset" operand "n" operand 1 SRAWI 0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch 11 dup "offset" operand LWZX - 11 dup compiled-header-size ADDI + 11 dup word-xt-offset LWZ r> call ] H{ { +input+ { { f "n" } } } diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor index a9aea95b4d..72c4ab335c 100644 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -14,4 +14,4 @@ namespaces alien.c-types kernel system combinators ; T{ ppc-backend } compiler-backend set-global -6 cells set-profiler-prologues +6 cells profiler-prologue set-global diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 62ea28609b..601a4ae63d 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -275,7 +275,7 @@ T{ x86-backend f 4 } compiler-backend set-global JNE ] { } define-if-intrinsic -10 set-profiler-prologues +10 profiler-prologue set-global "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 1301efb8aa..4f1bbcb833 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -201,4 +201,4 @@ M: struct-type flatten-value-type ( type -- seq ) ] each ] if ; -12 set-profiler-prologues +12 profiler-prologue set-global diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 655b23e517..42121759c3 100644 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -15,25 +15,20 @@ $nl "The main entry point into the code generator:" { $subsection generate } "Primitive compiler interface exported by the Factor VM:" -{ $subsection add-compiled-block } -{ $subsection finalize-compile } ; +{ $subsection modify-code-heap } ; ABOUT: "generator" HELP: compiled-xts -{ $var-description "During compilation, holds a hashtable mapping words to temporary uninterned words. The XT of each value points to the compiled code block of each key; at the end of compilation, the XT of each key is set to the XT of the value." } ; +{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ; HELP: compiling? { $values { "word" word } { "?" "a boolean" } } { $description "Tests if a word is going to be or already is compiled." } ; -HELP: finalize-compile ( xts -- ) -{ $values { "xts" "an association list mapping words to uninterned words" } } -{ $description "Performs relocation, atomically changes the XT of each key to the XT of each value, and flushes the CPU instruction cache on architectures where this has to be done manually." } ; - -HELP: add-compiled-block ( literals words rel labels code -- xt ) -{ $values { "literals" vector } { "words" "a vector of words" } { "rel" "a vector of integers" } { "labels" "an array of integers" } { "code" "a vector of integers" } { "xt" "an uninterned word" } } -{ $description "Adds a new compiled block and outputs an uninterned word whose XT points at this block. This uninterned word can then be passed to " { $link finalize-compile } "." } ; +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 be382b565d..6b18e32204 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -36,6 +36,8 @@ t compiled-stack-traces? set-global compiled-stack-traces? get compiling-word get f ? literal-table get push ; +: 6array 3array >r 3array r> append ; + : generate-1 ( word label node quot -- ) pick f save-xt [ roll compiling-word set @@ -44,7 +46,7 @@ t compiled-stack-traces? set-global call literal-table get >array word-table get >array - ] { } make fixup add-compiled-block save-xt ; + ] { } make fixup 6array save-xt ; : generate-profiler-prologue ( -- ) compiled-stack-traces? get [ @@ -65,6 +67,7 @@ GENERIC: generate-node ( node -- next ) current-label-start define-label current-label-start resolve-label [ generate-nodes ] with-node-iterator + profiler-prologue get ] generate-1 ; : word-dataflow ( word -- dataflow ) @@ -84,11 +87,7 @@ SYMBOL: batch-mode : compile-begins ( word -- ) compiler-hook get call - "quiet" get batch-mode get or [ - drop - ] [ - "Compiling " write . flush - ] if ; + "quiet" get [ drop ] [ "Compiling " write . flush ] if ; : (compile) ( word -- ) dup compiling? not over compound? and [ @@ -192,6 +191,7 @@ M: #if generate-node %save-dispatch-xt %prologue-later [ generate-nodes ] with-node-iterator + 0 ] generate-1 ] keep ; diff --git a/core/words/words.factor b/core/words/words.factor index 93c08ff435..2d91ef47a9 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -94,7 +94,6 @@ M: word uses ( word -- seq ) word-def quot-uses keys ; M: compound redefined* ( word -- ) - dup changed-word { "inferred-effect" "base-case" "no-effect" } reset-props ; finalized) - { - case false: - for(scan = words_start; scan < words_end; scan += CELLS) - copy_handle((CELL*)scan); - break; - case true: - break; - default: - critical_error("Invalid compiled->finalized",(CELL)compiled); - } + for(scan = words_start; scan < words_end; scan += CELLS) + copy_handle((CELL*)scan); } /* Copy literals referenced from all code blocks to newspace */ @@ -305,18 +294,6 @@ void recursive_mark(F_BLOCK *block) F_COMPILED *compiled = block_to_compiled(block); iterate_code_heap_step(compiled,collect_literals_step); - - switch(compiled->finalized) - { - case false: - break; - case true: - iterate_code_heap_step(compiled,mark_sweep_step); - break; - default: - critical_error("Invalid compiled->finalized",(CELL)compiled); - break; - } } /* Push the free space and total size of the code heap */ diff --git a/vm/code_heap.c b/vm/code_heap.c index ccf2c99a38..da5f2a39ce 100644 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -42,6 +42,8 @@ static CELL xt_offset; INLINE CELL compute_code_rel(F_REL *rel, CELL code_start, CELL literals_start, CELL words_start) { + F_WORD *word; + switch(REL_TYPE(rel)) { case RT_PRIMITIVE: @@ -53,11 +55,11 @@ INLINE CELL compute_code_rel(F_REL *rel, case RT_DISPATCH: return CREF(words_start,REL_ARGUMENT(rel)); case RT_XT: - return get(CREF(words_start,REL_ARGUMENT(rel))) - + sizeof(F_COMPILED) + xt_offset; + word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); + return (CELL)word->code + sizeof(F_COMPILED) + xt_offset; case RT_XT_PROFILING: - return get(CREF(words_start,REL_ARGUMENT(rel))) - + sizeof(F_COMPILED); + word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); + return (CELL)word->code + sizeof(F_COMPILED); case RT_LABEL: return code_start + REL_ARGUMENT(rel); default: @@ -133,7 +135,7 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value) void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) { - xt_offset = (profiling_p() ? 0 : profiler_prologue()); + xt_offset = (profiling_p() ? 0 : relocating->profiler_prologue); F_REL *rel = (F_REL *)reloc_start; F_REL *rel_end = (F_REL *)literals_start; @@ -174,16 +176,6 @@ direct XT references, and perform fixups */ void finalize_code_block(F_COMPILED *relocating, CELL code_start, CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) { - CELL scan; - - if(relocating->finalized != false) - critical_error("Finalizing a finalized block",(CELL)relocating); - - for(scan = words_start; scan < words_end; scan += CELLS) - put(scan,(CELL)(untag_word(get(scan))->code)); - - relocating->finalized = true; - if(reloc_start != literals_start) { relocate_code_block(relocating,code_start,reloc_start, @@ -242,8 +234,10 @@ CELL allot_code_block(CELL size) return start; } +/* Might GC */ F_COMPILED *add_compiled_block( CELL type, + CELL profiler_prologue, F_ARRAY *code, F_ARRAY *labels, F_ARRAY *rel, @@ -279,7 +273,7 @@ F_COMPILED *add_compiled_block( header->reloc_length = rel_length; header->literals_length = literals_length; header->words_length = words_length; - header->finalized = false; + header->profiler_prologue = profiler_prologue; here += sizeof(F_COMPILED); @@ -327,49 +321,46 @@ void set_word_xt(F_WORD *word, F_COMPILED *compiled) word->xt = (XT)(compiled + 1); if(!profiling_p()) - word->xt += profiler_prologue(); + word->xt += compiled->profiler_prologue; word->compiledp = T; } -DEFINE_PRIMITIVE(add_compiled_block) +DEFINE_PRIMITIVE(modify_code_heap) { - F_ARRAY *code = untag_array(dpop()); - F_ARRAY *labels = untag_array(dpop()); - F_ARRAY *rel = untag_array(dpop()); - F_ARRAY *words = untag_array(dpop()); - F_ARRAY *literals = untag_array(dpop()); + F_ARRAY *alist = untag_array(dpop()); - F_COMPILED *compiled = add_compiled_block(WORD_TYPE,code,labels,rel,words,literals); - - /* push a new word whose XT points to this code block on the stack */ - F_WORD *word = allot_word(F,F); - set_word_xt(word,compiled); - dpush(tag_object(word)); -} - -/* After batch compiling a bunch of words, perform various fixups to make them -executable */ -DEFINE_PRIMITIVE(finalize_compile) -{ - F_ARRAY *array = untag_array(dpop()); - - /* set word XT's */ - CELL count = untag_fixnum_fast(array->capacity); + CELL count = untag_fixnum_fast(alist->capacity); CELL i; for(i = 0; i < count; i++) { - F_ARRAY *pair = untag_array(array_nth(array,i)); - F_WORD *word = untag_word(array_nth(pair,0)); - F_COMPILED *compiled = untag_word(array_nth(pair,1))->code; + F_ARRAY *data = 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)); + + REGISTER_UNTAGGED(alist); + REGISTER_UNTAGGED(word); + + 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); } - /* perform relocation */ - for(i = 0; i < count; i++) - { - F_ARRAY *pair = untag_array(array_nth(array,i)); - F_WORD *word = untag_word(array_nth(pair,0)); - iterate_code_heap_step(word->code,finalize_code_block); - } + iterate_code_heap(finalize_code_block); } diff --git a/vm/code_heap.h b/vm/code_heap.h index 45312fca02..7a0c0976c0 100644 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -63,6 +63,7 @@ void set_word_xt(F_WORD *word, F_COMPILED *compiled); F_COMPILED *add_compiled_block( CELL type, + CELL profiler_prologue, F_ARRAY *code, F_ARRAY *labels, F_ARRAY *rel, @@ -71,5 +72,4 @@ F_COMPILED *add_compiled_block( CELL compiled_code_format(void); -DECLARE_PRIMITIVE(add_compiled_block); -DECLARE_PRIMITIVE(finalize_compile); +DECLARE_PRIMITIVE(modify_code_heap); diff --git a/vm/image.c b/vm/image.c index c90f0ae5b0..32158fddbd 100755 --- a/vm/image.c +++ b/vm/image.c @@ -275,12 +275,7 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start, data_fixup((CELL*)scan); for(scan = words_start; scan < words_end; scan += CELLS) - { - if(relocating->finalized) - code_fixup(scan); - else - data_fixup((CELL*)scan); - } + data_fixup((CELL*)scan); if(reloc_start != literals_start) { diff --git a/vm/layouts.h b/vm/layouts.h index 65d9fa4359..b53f6a3eef 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -152,7 +152,7 @@ typedef struct CELL reloc_length; /* # bytes */ CELL literals_length; /* # bytes */ CELL words_length; /* # bytes */ - CELL finalized; /* has finalize_code_block() been called on this yet? */ + CELL profiler_prologue; /* # bytes */ CELL padding[2]; } F_COMPILED; diff --git a/vm/primitives.c b/vm/primitives.c index 422096f931..093af85f17 100644 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -112,7 +112,7 @@ void *primitives[] = { primitive_tag, primitive_cwd, primitive_cd, - primitive_add_compiled_block, + primitive_modify_code_heap, primitive_dlopen, primitive_dlsym, primitive_dlclose, @@ -166,7 +166,6 @@ void *primitives[] = { primitive_end_scan, primitive_size, primitive_die, - primitive_finalize_compile, primitive_fopen, primitive_fgetc, primitive_fread, diff --git a/vm/profiler.c b/vm/profiler.c index df62b4a3e5..ec1eaf7582 100644 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -5,11 +5,6 @@ bool profiling_p(void) return to_boolean(userenv[PROFILING_ENV]); } -F_FIXNUM profiler_prologue(void) -{ - return to_fixnum(userenv[PROFILER_PROLOGUE_ENV]); -} - void profiling_word(F_WORD *word) { /* If we just enabled the profiler, reset call count */ diff --git a/vm/profiler.h b/vm/profiler.h index 2c5cdb5206..5cb7ea1856 100644 --- a/vm/profiler.h +++ b/vm/profiler.h @@ -1,3 +1,2 @@ bool profiling_p(void); -F_FIXNUM profiler_prologue(void); DECLARE_PRIMITIVE(profiling); diff --git a/vm/quotations.c b/vm/quotations.c index 649aaf8189..174c5fdbea 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -155,7 +155,7 @@ void jit_compile(F_QUOTATION *quot) F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot)); UNREGISTER_UNTAGGED(result); - F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,result,NULL,NULL,NULL,literals); + F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,0,result,NULL,NULL,NULL,literals); iterate_code_heap_step(compiled,finalize_code_block); UNREGISTER_UNTAGGED(quot); diff --git a/vm/run.h b/vm/run.h index 52f02c9c08..7075999b7f 100644 --- a/vm/run.h +++ b/vm/run.h @@ -52,7 +52,6 @@ typedef enum { /* Profiler support */ PROFILING_ENV = 38, /* is the profiler on? */ - PROFILER_PROLOGUE_ENV /* length of optimizing compiler's profiler prologue */ } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV From 3c5b2073efcc23df283cd718c5bcbb07d42bba93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Dec 2007 18:42:56 -0500 Subject: [PATCH 03/82] Fix save-image-and-exit, clean up compiler a bit --- core/bootstrap/compiler/compiler.factor | 2 +- core/compiler/compiler-docs.factor | 4 -- core/compiler/compiler.factor | 34 ++++------ core/cpu/x86/architecture/architecture.factor | 2 +- core/memory/memory-tests.factor | 2 + vm/code_gc.c | 68 ++++++++----------- vm/code_heap.c | 3 + vm/data_gc.h | 3 - vm/image.c | 8 ++- vm/quotations.c | 3 + vm/types.c | 8 +-- 11 files changed, 63 insertions(+), 74 deletions(-) mode change 100644 => 100755 core/compiler/compiler-docs.factor mode change 100644 => 100755 core/compiler/compiler.factor mode change 100644 => 100755 core/memory/memory-tests.factor mode change 100644 => 100755 vm/code_heap.c mode change 100644 => 100755 vm/data_gc.h mode change 100644 => 100755 vm/types.c diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 4e06980bab..44c68d32f0 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -33,7 +33,7 @@ global [ { "compiler" } add-use ] bind delegate - underlying2 + underlying find-pair-next namestack* diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor old mode 100644 new mode 100755 index ff82505102..b7e96a33ff --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -11,7 +11,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Three utility words for bulk compilation:" { $subsection compile-batch } { $subsection compile-vocabs } -{ $subsection compile-all } "Bulk compilation saves compile warnings and errors in a global variable, instead of printing them as they arise:" { $subsection compile-errors } "The warnings and errors can be viewed later:" @@ -113,9 +112,6 @@ HELP: recompile { $description "Recompiles words whose compiled definitions have become out of date as a result of dependent words being redefined." } ; HELP: compile-all -{ $description "Compiles all words which have not been compiled yet." } ; - -HELP: recompile-all { $description "Recompiles all words." } ; HELP: changed-words diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor old mode 100644 new mode 100755 index cd6fb979f0..42de8225c9 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -8,14 +8,13 @@ IN: compiler M: object inference-error-major? drop t ; : compile-error ( word error -- ) - batch-mode get [ - 2array compile-errors get push + compile-errors get [ + >r 2array r> push ] [ - "quiet" get [ drop ] [ print-error flush ] if drop - ] if ; + "quiet" get [ 2drop ] [ print-error flush drop ] if + ] if* ; : begin-batch ( -- ) - batch-mode on V{ } clone compile-errors set-global ; : compile-error. ( pair -- ) @@ -37,7 +36,6 @@ M: object inference-error-major? drop t ; : :warnings (:warnings) [ compile-error. ] each ; : end-batch ( -- ) - batch-mode off "quiet" get [ "Compile finished." print nl @@ -48,6 +46,9 @@ M: object inference-error-major? drop t ; nl ] unless ; +: with-compile-errors ( quot -- ) + [ begin-batch call end-batch ] with-scope ; inline + : compile ( word -- ) H{ } clone [ compiled-xts [ (compile) ] with-variable @@ -56,15 +57,10 @@ M: object inference-error-major? drop t ; : compile-failed ( word error -- ) dupd compile-error dup update-xt unchanged-word ; -: forget-errors ( seq -- ) - [ f "no-effect" set-word-prop ] each ; - : (compile-batch) ( words -- ) H{ } clone [ compiled-xts [ - [ - [ (compile) ] [ compile-failed ] recover - ] each + [ [ (compile) ] [ compile-failed ] recover ] each ] with-variable ] keep [ swap add* ] { } assoc>map modify-code-heap ; @@ -72,16 +68,11 @@ M: object inference-error-major? drop t ; dup empty? [ drop ] [ - dup begin-batch - dup forget-errors - (compile-batch) - end-batch + [ (compile-batch) ] with-compile-errors ] if ; : compile-vocabs ( seq -- ) [ words ] map concat compile-batch ; -: compile-all ( -- ) vocabs compile-vocabs ; - : compile-quot ( quot -- word ) define-temp dup compile ; : compile-1 ( quot -- ) compile-quot execute ; @@ -91,5 +82,8 @@ M: object inference-error-major? drop t ; dup keys compile-batch clear-assoc ] when* ; -: recompile-all ( -- ) - all-words [ changed-word ] each recompile ; +: forget-errors ( seq -- ) + [ f "no-effect" set-word-prop ] each ; + +: compile-all ( -- ) + all-words dup forget-errors [ changed-word ] each recompile ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index ac26705664..d059afe9f2 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -102,7 +102,7 @@ M: x86-backend %jump-t ( label -- ) ! x86, this is redundant. "scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch "n" operand "n" operand "scratch" operand [+] MOV - "n" operand compiled-header-size ADD ; + "n" operand dup word-xt-offset [+] MOV ; : dispatch-template ( word-table# quot -- ) [ diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor old mode 100644 new mode 100755 index 98d2779c1e..f543c08744 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -4,6 +4,8 @@ IN: temporary TUPLE: testing x y z ; +[ save-image-and-exit ] unit-test-fails + [ ] [ num-types get [ type>class [ diff --git a/vm/code_gc.c b/vm/code_gc.c index 24fd0b1ab2..8ae3ea5eda 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -264,18 +264,6 @@ void collect_literals(void) iterate_code_heap(collect_literals_step); } -/* Mark all XTs referenced from a code block */ -void mark_sweep_step(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) -{ - F_COMPILED **start = (F_COMPILED **)words_start; - F_COMPILED **end = (F_COMPILED **)words_end; - F_COMPILED **iter = start; - - while(iter < end) - recursive_mark(compiled_to_block(*iter++)); -} - /* Mark all XTs and literals referenced from a word XT */ void recursive_mark(F_BLOCK *block) { @@ -391,14 +379,14 @@ void forward_object_xts(void) F_WORD *word = untag_object(obj); if(word->compiledp != F) - set_word_xt(word,forward_xt(word->code)); + word->code = forward_xt(word->code); } else if(type_of(obj) == QUOTATION_TYPE) { F_QUOTATION *quot = untag_object(obj); if(quot->compiledp != F) - set_quot_xt(quot,forward_xt(quot->code)); + quot->code = forward_xt(quot->code); } else if(type_of(obj) == CALLSTACK_TYPE) { @@ -411,33 +399,33 @@ void forward_object_xts(void) gc_off = false; } -void compaction_code_block_fixup(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) +/* Set the XT fields now that the heap has been compacted */ +void fixup_object_xts(void) { - F_COMPILED **iter = (F_COMPILED **)words_start; - F_COMPILED **end = (F_COMPILED **)words_end; + begin_scan(); - while(iter < end) + CELL obj; + + while((obj = next_object()) != F) { - *iter = forward_xt(*iter); - iter++; - } -} - -void forward_block_xts(void) -{ - F_BLOCK *scan = first_block(&code_heap); - - while(scan) - { - if(scan->status == B_ALLOCATED) + if(type_of(obj) == WORD_TYPE) { - iterate_code_heap_step(block_to_compiled(scan), - compaction_code_block_fixup); - } + F_WORD *word = untag_object(obj); - scan = next_block(&code_heap,scan); + if(word->compiledp != F) + set_word_xt(word,word->code); + } + else if(type_of(obj) == QUOTATION_TYPE) + { + F_QUOTATION *quot = untag_object(obj); + + if(quot->compiledp != F) + set_quot_xt(quot,quot->code); + } } + + /* End the heap scan */ + gc_off = false; } void compact_heap(F_HEAP *heap) @@ -450,7 +438,6 @@ void compact_heap(F_HEAP *heap) if(scan->status == B_ALLOCATED && scan != scan->forwarding) memcpy(scan->forwarding,scan,scan->size); - scan = next; } } @@ -465,19 +452,20 @@ void compact_code_heap(void) code_gc(); fprintf(stderr,"*** Code heap compaction...\n"); + fflush(stderr); /* Figure out where the code heap blocks are going to end up */ CELL size = compute_heap_forwarding(&code_heap); - /* Update word and quotation XTs to point to the new locations */ + /* Update word and quotation code pointers */ forward_object_xts(); - /* Update code block XTs to point to the new locations */ - forward_block_xts(); - /* Actually perform the compaction */ compact_heap(&code_heap); + /* Update word and quotation XTs */ + fixup_object_xts(); + /* Now update the free list; there will be a single free block at the end */ build_free_list(&code_heap,size); diff --git a/vm/code_heap.c b/vm/code_heap.c old mode 100644 new mode 100755 index da5f2a39ce..8f79078862 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -317,6 +317,9 @@ F_COMPILED *add_compiled_block( void set_word_xt(F_WORD *word, F_COMPILED *compiled) { + if(compiled->type != WORD_TYPE) + critical_error("bad param to set_word_xt",(CELL)compiled); + word->code = compiled; word->xt = (XT)(compiled + 1); diff --git a/vm/data_gc.h b/vm/data_gc.h old mode 100644 new mode 100755 index cb0b6fbad3..ae11c5746a --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -239,9 +239,6 @@ DEFPUSHPOP(root_,extra_roots) #define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0) #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop()) -#define REGISTER_STRING(obj) REGISTER_UNTAGGED(obj) -#define UNREGISTER_STRING(obj) UNREGISTER_UNTAGGED(obj) - /* We ignore strings which point outside the data heap, but we might be given a char* which points inside the data heap, in which case it is a root, for example if we call unbox_char_string() the result is placed in a byte array */ diff --git a/vm/image.c b/vm/image.c index 32158fddbd..d5ee02cca0 100755 --- a/vm/image.c +++ b/vm/image.c @@ -150,6 +150,10 @@ DEFINE_PRIMITIVE(save_image) DEFINE_PRIMITIVE(save_image_and_exit) { + F_CHAR *path = unbox_native_string(); + + REGISTER_C_STRING(path); + /* strip out userenv data which is set on startup anyway */ CELL i; for(i = 0; i < FIRST_SAVE_ENV; i++) @@ -158,8 +162,10 @@ DEFINE_PRIMITIVE(save_image_and_exit) /* do a full GC + code heap compaction */ compact_code_heap(); + UNREGISTER_C_STRING(path); + /* Save the image */ - save_image(unbox_native_string()); + save_image(path); /* now exit; we cannot continue executing like this */ exit(0); diff --git a/vm/quotations.c b/vm/quotations.c index 174c5fdbea..97baf2afe9 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -39,6 +39,9 @@ bool jit_stack_frame_p(F_ARRAY *array) void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code) { + if(code->type != QUOTATION_TYPE) + critical_error("bad param to set_word_xt",(CELL)code); + quot->code = code; quot->xt = (XT)(code + 1); quot->compiledp = T; diff --git a/vm/types.c b/vm/types.c old mode 100644 new mode 100755 index a62dfb3125..272625f000 --- a/vm/types.c +++ b/vm/types.c @@ -285,9 +285,9 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) if(capacity < to_copy) to_copy = capacity; - REGISTER_STRING(string); + REGISTER_UNTAGGED(string); F_STRING *new_string = allot_string_internal(capacity); - UNREGISTER_STRING(string); + UNREGISTER_UNTAGGED(string); memcpy(new_string + 1,string + 1,to_copy * CHARS); fill_string(new_string,to_copy,capacity,fill); @@ -381,9 +381,9 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) F_BYTE_ARRAY *_c_str; \ if(check && !check_string(s,sizeof(type))) \ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ - REGISTER_STRING(s); \ + REGISTER_UNTAGGED(s); \ _c_str = allot_c_string(capacity,sizeof(type)); \ - UNREGISTER_STRING(s); \ + UNREGISTER_UNTAGGED(s); \ type *c_str = (type*)(_c_str + 1); \ type##_string_to_memory(s,c_str); \ c_str[capacity] = 0; \ From 7b17a9fcc207cefcdcee337ec8a3d302abb7e7ea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Dec 2007 18:43:26 -0500 Subject: [PATCH 04/82] Fix 'make clean' and release scripts --- Makefile | 1 + misc/source-release.sh | 2 +- misc/windows-release.sh | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) mode change 100644 => 100755 Makefile mode change 100644 => 100755 misc/source-release.sh mode change 100644 => 100755 misc/windows-release.sh diff --git a/Makefile b/Makefile old mode 100644 new mode 100755 index 4228a6f8ad..4b5d16b9c3 --- a/Makefile +++ b/Makefile @@ -140,6 +140,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS) clean: rm -f vm/*.o + rm libfactor.a vm/resources.o: windres vm/factor.rs vm/resources.o diff --git a/misc/source-release.sh b/misc/source-release.sh old mode 100644 new mode 100755 index 37aa98e1e3..6b1bb2dafc --- a/misc/source-release.sh +++ b/misc/source-release.sh @@ -1,5 +1,5 @@ source misc/version.sh -rm -rf .git +rm -rf .git .gitignore cd .. tar cfz Factor-$VERSION.tar.gz factor/ diff --git a/misc/windows-release.sh b/misc/windows-release.sh old mode 100644 new mode 100755 index 93d0d3fa5b..7c3941a39a --- a/misc/windows-release.sh +++ b/misc/windows-release.sh @@ -15,7 +15,7 @@ wget http://factorcode.org/images/$VERSION/boot.x86.32.image CMD="./factor-nt -i=boot.x86.32.image -no-user-init $FLAGS" echo $CMD $CMD -rm -rf .git/ +rm -rf .git/ .gitignore rm -rf Factor.app/ rm -rf vm/ rm -f Makefile From 9ef535bc77d0ce0cce96702f08f138978d40dc46 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Dec 2007 20:34:44 -0500 Subject: [PATCH 05/82] Add greendale's partition combinator to sequences.lib --- extra/sequences/lib/lib.factor | 9 +++++++++ 1 file changed, 9 insertions(+) mode change 100644 => 100755 extra/sequences/lib/lib.factor diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor old mode 100644 new mode 100755 index f5adccf445..a28fe32818 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -104,3 +104,12 @@ PRIVATE> : power-set ( seq -- subsets ) 2 over length exact-number-strings swap [ nths ] curry map ; + +: push-either ( elt quot accum1 accum2 -- ) + >r >r keep swap r> r> ? push ; inline + +: 2pusher ( quot -- quot accum1 accum2 ) + V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline + +: partition ( seq quot -- trueseq falseseq ) + over >r 2pusher >r >r each r> r> r> drop ; inline From 43dd70398140fdb83a595e3f81df739bc364d0d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Dec 2007 20:35:00 -0500 Subject: [PATCH 06/82] Simplifying the compiler and parser a little bit --- core/bootstrap/stage2.factor | 6 ++- core/compiler/compiler-docs.factor | 4 +- core/compiler/compiler.factor | 67 +++--------------------------- core/generator/generator.factor | 2 - core/listener/listener.factor | 3 +- core/parser/parser-docs.factor | 6 +-- core/parser/parser.factor | 8 ++-- core/vocabs/loader/loader.factor | 2 +- 8 files changed, 18 insertions(+), 80 deletions(-) mode change 100644 => 100755 core/listener/listener.factor mode change 100644 => 100755 core/parser/parser.factor mode change 100644 => 100755 core/vocabs/loader/loader.factor diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 59daa3ab53..3973af8bf4 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -40,12 +40,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 - ] no-parse-hook + ] with-variable + + do-parse-hook init-io init-stdio diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index b7e96a33ff..018336803e 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -20,9 +20,7 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler" ARTICLE: "recompile" "Automatic recompilation" "When a word is redefined, you can recompile all affected words automatically:" -{ $subsection recompile } -"Normally loading a source file or a module also calls " { $link recompile } ". This can be disabled by wrapping file loading in a combinator:" -{ $subsection no-parse-hook } ; +{ $subsection recompile } ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 42de8225c9..4d6529fc7f 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -5,71 +5,14 @@ generator debugger math.parser prettyprint words continuations vocabs assocs alien.compiler ; IN: compiler -M: object inference-error-major? drop t ; - -: compile-error ( word error -- ) - compile-errors get [ - >r 2array r> push - ] [ - "quiet" get [ 2drop ] [ print-error flush drop ] if - ] if* ; - -: begin-batch ( -- ) - V{ } clone compile-errors set-global ; - -: compile-error. ( pair -- ) - nl - "While compiling " write dup first pprint ": " print - nl - second print-error ; - -: (:errors) ( -- seq ) - compile-errors get-global - [ second inference-error-major? ] subset ; - -: :errors (:errors) [ compile-error. ] each ; - -: (:warnings) ( -- seq ) - compile-errors get-global - [ second inference-error-major? not ] subset ; - -: :warnings (:warnings) [ compile-error. ] each ; - -: end-batch ( -- ) - "quiet" get [ - "Compile finished." print - nl - ":errors - print " write (:errors) length pprint - " compiler errors." print - ":warnings - print " write (:warnings) length pprint - " compiler warnings." print - nl - ] unless ; - -: with-compile-errors ( quot -- ) - [ begin-batch call end-batch ] with-scope ; inline - -: compile ( word -- ) - H{ } clone [ - compiled-xts [ (compile) ] with-variable - ] keep [ swap add* ] { } assoc>map modify-code-heap ; - -: compile-failed ( word error -- ) - dupd compile-error dup update-xt unchanged-word ; - -: (compile-batch) ( words -- ) +: compile-batch ( words -- ) H{ } clone [ compiled-xts [ - [ [ (compile) ] [ compile-failed ] recover ] each + [ [ (compile) ] curry [ print-error ] recover ] each ] with-variable ] keep [ swap add* ] { } assoc>map modify-code-heap ; -: compile-batch ( seq -- ) - dup empty? [ - drop - ] [ - [ (compile-batch) ] with-compile-errors - ] if ; +: compile ( word -- ) 1array compile-batch ; : compile-vocabs ( seq -- ) [ words ] map concat compile-batch ; @@ -86,4 +29,6 @@ M: object inference-error-major? drop t ; [ f "no-effect" set-word-prop ] each ; : compile-all ( -- ) - all-words dup forget-errors [ changed-word ] each recompile ; + all-words + dup forget-errors [ changed-word ] each + recompile ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 6b18e32204..b2868b5a96 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -83,8 +83,6 @@ SYMBOL: compiler-hook SYMBOL: compile-errors -SYMBOL: batch-mode - : compile-begins ( word -- ) compiler-hook get call "quiet" get [ drop ] [ "Compiling " write . flush ] if ; diff --git a/core/listener/listener.factor b/core/listener/listener.factor old mode 100644 new mode 100755 index 188a5e354d..6ff8d6a4af --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -47,7 +47,8 @@ M: duplex-stream parse-interactive : listen ( -- ) listener-hook get call prompt. [ - stdio get parse-interactive [ call ] [ bye ] if* + stdio get parse-interactive + [ do-parse-hook call ] [ bye ] if* ] try ; : until-quit ( -- ) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index eea23733eb..2fd560943e 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -528,11 +528,7 @@ HELP: eval 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 no-parse-hook } related-words - -HELP: no-parse-hook -{ $values { "quot" "a quotation" } } -{ $description "Runs the quotation in a new dynamic scope where " { $link parse-hook } " is set to " { $link f } ", then calls the outer " { $link parse-hook } " after the quotation returns. This has the effect of postponing any recompilation to the end of a quotation." } ; +{ parse-hook do-parse-hook } related-words HELP: start-parsing { $values { "stream" "an input stream" } { "name" "a pathname string" } } diff --git a/core/parser/parser.factor b/core/parser/parser.factor old mode 100644 new mode 100755 index 235d0e935a..441eaca9cf --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -372,9 +372,6 @@ SYMBOL: parse-hook "Loading " write . flush ] if ; -: no-parse-hook ( quot -- ) - >r f parse-hook r> with-variable do-parse-hook ; inline - : start-parsing ( stream name -- ) H{ } clone new-definitions set dup [ @@ -445,8 +442,9 @@ SYMBOL: parse-hook start-parsing \ contents get string-lines parse-fresh dup finish-parsing - ] [ ] [ undo-parsing ] cleanup - ] no-parse-hook ; + do-parse-hook + ] with-scope + ] [ ] [ undo-parsing ] cleanup ; : parse-file-restarts ( file -- restarts ) "Load " swap " again" 3append t 2array 1array ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor old mode 100644 new mode 100755 index a7a112b58a..e24955481b --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -154,7 +154,7 @@ SYMBOL: load-help? 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune [ [ require ] each ] no-parse-hook ; + append prune [ require ] each ; : refresh ( prefix -- ) to-refresh do-refresh ; From 51992905b22155bd29521eca556aa826b72bd3c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Dec 2007 16:29:26 -0500 Subject: [PATCH 07/82] Inference tests tweak --- core/inference/inference-tests.factor | 3 +-- extra/io/launcher/launcher-tests.factor | 4 ++++ 2 files changed, 5 insertions(+), 2 deletions(-) create mode 100755 extra/io/launcher/launcher-tests.factor diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3462dee83a..7dae2e44d8 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector bootstrap.image tuples classes.union classes.predicate debugger bootstrap.image -bootstrap.image.private io.launcher threads.private +bootstrap.image.private threads.private io.streams.string combinators.private tools.test.inference ; IN: temporary @@ -454,7 +454,6 @@ DEFER: bar ! Test odds and ends { 1 1 } [ ' ] unit-test-effect { 2 0 } [ write-image ] unit-test-effect -{ 1 1 } [ ] unit-test-effect { 0 0 } [ idle-thread ] unit-test-effect ! Incorrect stack declarations on inline recursive words should diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor new file mode 100755 index 0000000000..06b80c0ba7 --- /dev/null +++ b/extra/io/launcher/launcher-tests.factor @@ -0,0 +1,4 @@ +IN: temporary +USING: tools.test tools.test.inference io.launcher ; + +{ 1 1 } [ ] unit-test-effect From 308cf5aef7bfb37266c64492e56b8d3adbcca5c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Dec 2007 16:29:54 -0500 Subject: [PATCH 08/82] Listener auto-compiles; more smart recompile work in progress --- core/compiler/batch/batch.factor | 86 +++++++++++++--------------- core/compiler/compiler.factor | 46 +++++++++++---- core/generator/generator-docs.factor | 4 +- core/generator/generator.factor | 46 ++++++--------- core/listener/listener.factor | 2 +- core/parser/parser.factor | 4 +- vm/code_heap.c | 18 +++++- 7 files changed, 115 insertions(+), 91 deletions(-) mode change 100644 => 100755 core/compiler/batch/batch.factor mode change 100644 => 100755 core/generator/generator-docs.factor diff --git a/core/compiler/batch/batch.factor b/core/compiler/batch/batch.factor old mode 100644 new mode 100755 index 3c725bbc9a..13d0295e9e --- a/core/compiler/batch/batch.factor +++ b/core/compiler/batch/batch.factor @@ -5,50 +5,46 @@ optimizer arrays definitions sequences assocs continuations generator compiler ; IN: compiler.batch -! SYMBOL: compile-queue -! SYMBOL: compile-results -! -! TUPLE: compiled literals words rel labels code ; -! -! C: compiled -! -! : queue-compile ( word -- ) -! compile-queue get push-front ; -! -! : word-dataflow ( word -- effect dataflow ) -! [ -! dup "no-effect" word-prop [ no-effect ] when -! dup specialized-def over dup 2array 1array infer-quot -! finish-word -! ] with-infer ; -! -! : compiled-usage usage [ word? ] subset ; -! -! : ripple-up ( effect word -- ) -! tuck "compiled-effect" word-prop = -! [ drop ] [ compiled-usage [ queue-compile ] each ] if ; -! -! : save-effect ( effect word -- ) -! swap "compiled-effect" set-word-prop ; -! -! : add-compiled ( word -- ) -! >r f f f f f r> compile-results get set-at ; -! -! : compile-1 ( word -- ) -! dup compile-results get at [ drop ] [ -! [ [ word-dataflow drop ] [ 2drop f ] recover ] keep -! 2dup ripple-up -! tuck save-effect -! add-compiled -! ] if ; -! -! : compile-batch ( words -- ) -! [ -! compile-queue set -! [ queue-compile ] each -! H{ } clone compile-results set -! compile-queue get [ compile-1 ] dlist-slurp -! compile-results get -! ] with-scope ; +: with-compilation-unit ( quot -- ) + H{ } clone + [ compiled-xts swap with-variable ] keep + [ swap add* ] { } assoc>map modify-code-heap ; +: compile-batch ( words -- ) + [ [ (compile) ] curry [ print-error ] recover ] each ; +SYMBOL: compile-queue + +: queue-compile ( word -- ) + compile-queue get push-front ; + +: compiled-usage ( word -- seq ) + #! XXX + usage [ word? ] subset ; + +: ripple-up ( effect word -- ) + tuck "compiled-effect" word-prop = + [ drop ] [ compiled-usage [ queue-compile ] each ] if ; + +: save-effect ( effect word -- ) + swap "compiled-effect" set-word-prop ; + +: add-compiled ( word -- ) + >r f f f f f r> compile-results get set-at ; + +: compile-1 ( word -- ) + dup compile-results get at [ drop ] [ + [ [ word-dataflow drop ] [ 2drop f ] recover ] keep + 2dup ripple-up + tuck save-effect + add-compiled + ] if ; + +: compile-batch ( words -- ) + [ + compile-queue set + [ queue-compile ] each + H{ } clone compile-results set + compile-queue get [ compile-1 ] dlist-slurp + compile-results get + ] with-scope ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 4d6529fc7f..2c39b7f0e2 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -2,23 +2,49 @@ ! 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 ; +vocabs assocs alien.compiler dlists optimizer ; IN: compiler +SYMBOL: compiler-hook + +: compile-begins ( word -- ) + compiler-hook get [ call ] when* + "quiet" get [ drop ] [ "Compiling " write . flush ] if ; + +: (compile) ( word -- ) + dup compiling? not over compound? and [ + [ + dup compile-begins + dup dup word-dataflow nip optimize generate + ] curry [ print-error ] recover + ] [ drop ] if ; + +: finish-compilation-unit ( assoc -- ) + [ swap add* ] { } assoc>map modify-code-heap ; + +: with-compilation-unit ( quot -- ) + [ + compile-queue set + H{ } clone compiled-xts set + call + compile-queue get [ (compile) ] dlist-slurp + compiled-xts get finish-compilation-unit + ] with-scope ; inline + : compile-batch ( words -- ) - H{ } clone [ - compiled-xts [ - [ [ (compile) ] curry [ print-error ] recover ] each - ] with-variable - ] keep [ swap add* ] { } assoc>map modify-code-heap ; + [ [ queue-compile ] each ] with-compilation-unit ; -: compile ( word -- ) 1array compile-batch ; +: compile ( word -- ) + [ queue-compile ] with-compilation-unit ; -: compile-vocabs ( seq -- ) [ words ] map concat compile-batch ; +: compile-vocabs ( seq -- ) + [ words ] map concat compile-batch ; -: compile-quot ( quot -- word ) define-temp dup compile ; +: compile-quot ( quot -- word ) + define-temp dup compile ; -: compile-1 ( quot -- ) compile-quot execute ; +: compile-1 ( quot -- ) + compile-quot execute ; : recompile ( -- ) changed-words get [ diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor old mode 100644 new mode 100755 index 42121759c3..b5e3ef0f24 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax words debugger generator.fixup -generator.registers quotations kernel vectors arrays ; +generator.registers quotations kernel vectors arrays effects ; IN: generator ARTICLE: "generator" "Compiled code generator" @@ -64,7 +64,7 @@ HELP: generate { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ; HELP: word-dataflow -{ $values { "word" word } { "dataflow" "a dataflow graph" } } +{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } } { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ; HELP: define-intrinsics diff --git a/core/generator/generator.factor b/core/generator/generator.factor index b2868b5a96..aebc359bb9 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -4,13 +4,20 @@ USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer prettyprint -quotations sequences system threads words ; +quotations sequences system threads words dlists ; IN: generator +SYMBOL: compile-queue + SYMBOL: compiled-xts -: save-xt ( word xt -- ) - swap dup unchanged-word compiled-xts get set-at ; +: 6array 3array >r 3array r> append ; + +: begin-compiling ( word -- ) + 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 ; : compiling? ( word -- ? ) { @@ -19,6 +26,9 @@ SYMBOL: compiled-xts { [ t ] [ compiled? ] } } cond ; +: queue-compile ( word -- ) + compile-queue get push-front ; + SYMBOL: compiling-word SYMBOL: compiling-label @@ -36,17 +46,15 @@ t compiled-stack-traces? set-global compiled-stack-traces? get compiling-word get f ? literal-table get push ; -: 6array 3array >r 3array r> append ; - : generate-1 ( word label node quot -- ) - pick f save-xt [ + pick begin-compiling [ roll compiling-word set pick compiling-label set init-generator call literal-table get >array word-table get >array - ] { } make fixup 6array save-xt ; + ] { } make fixup finish-compiling ; : generate-profiler-prologue ( -- ) compiled-stack-traces? get [ @@ -70,30 +78,12 @@ GENERIC: generate-node ( node -- next ) profiler-prologue get ] generate-1 ; -: word-dataflow ( word -- dataflow ) +: word-dataflow ( word -- effect dataflow ) [ dup "no-effect" word-prop [ no-effect ] when dup specialized-def over dup 2array 1array infer-quot finish-word - ] with-infer nip ; - -SYMBOL: compiler-hook - -[ ] compiler-hook set-global - -SYMBOL: compile-errors - -: compile-begins ( word -- ) - compiler-hook get call - "quiet" get [ drop ] [ "Compiling " write . flush ] if ; - -: (compile) ( word -- ) - dup compiling? not over compound? and [ - dup compile-begins - dup dup word-dataflow optimize generate - ] [ - drop - ] if ; + ] with-infer ; : intrinsics ( #call -- quot ) node-param "intrinsics" word-prop ; @@ -140,7 +130,7 @@ M: node generate-node drop iterate-next ; } cond ; : generate-call ( label -- next ) - dup (compile) + dup queue-compile end-basic-block tail-call? [ %jump f diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 6ff8d6a4af..f0ded202b0 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -48,7 +48,7 @@ M: duplex-stream parse-interactive listener-hook get call prompt. [ stdio get parse-interactive - [ do-parse-hook call ] [ bye ] if* + [ call ] [ bye ] if* ] try ; : until-quit ( -- ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 441eaca9cf..8d1b488822 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -443,8 +443,8 @@ SYMBOL: parse-hook \ contents get string-lines parse-fresh dup finish-parsing do-parse-hook - ] with-scope - ] [ ] [ undo-parsing ] cleanup ; + ] [ ] [ undo-parsing ] cleanup + ] with-scope ; : parse-file-restarts ( file -- restarts ) "Load " swap " again" 3append t 2array 1array ; diff --git a/vm/code_heap.c b/vm/code_heap.c index 8f79078862..049274af8a 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -38,6 +38,11 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) static CELL xt_offset; +void incompatible_call_error(void) +{ + critical_error("Calling non-optimized word from optimized word",0); +} + /* Compute an address to store at a relocation */ INLINE CELL compute_code_rel(F_REL *rel, CELL code_start, CELL literals_start, CELL words_start) @@ -56,10 +61,16 @@ INLINE CELL compute_code_rel(F_REL *rel, return CREF(words_start,REL_ARGUMENT(rel)); case RT_XT: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - return (CELL)word->code + sizeof(F_COMPILED) + xt_offset; + if(word->compiledp == F) + return (CELL)incompatible_call_error; + else + return (CELL)word->code + sizeof(F_COMPILED) + xt_offset; case RT_XT_PROFILING: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - return (CELL)word->code + sizeof(F_COMPILED); + if(word->compiledp == F) + return (CELL)incompatible_call_error; + else + return (CELL)word->code + sizeof(F_COMPILED); case RT_LABEL: return code_start + REL_ARGUMENT(rel); default: @@ -365,5 +376,6 @@ DEFINE_PRIMITIVE(modify_code_heap) set_word_xt(word,compiled); } - iterate_code_heap(finalize_code_block); + if(count != 0) + iterate_code_heap(finalize_code_block); } From 6636a75a8a45e9bae1ae54537bf46a09adb642b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Dec 2007 20:55:40 -0500 Subject: [PATCH 09/82] Move experimental code to core/compiler/ --- core/compiler/compiler.factor | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 2c39b7f0e2..71fd4ab64b 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -5,23 +5,43 @@ generator debugger math.parser prettyprint words continuations vocabs assocs alien.compiler dlists optimizer ; IN: compiler +: finish-compilation-unit ( assoc -- ) + [ swap add* ] { } assoc>map modify-code-heap ; + SYMBOL: compiler-hook : compile-begins ( word -- ) compiler-hook get [ call ] when* "quiet" get [ drop ] [ "Compiling " write . flush ] if ; +: compiled-usage ( word -- seq ) + #! XXX + usage [ word? ] subset ; + +: ripple-up ( word effect -- ) + over "compiled-effect" word-prop = + [ drop ] [ + compiled-usage + [ "was-compiled" word-prop ] subset + [ dup changed-word queue-compile ] each + ] if ; + +: save-effect ( word effect -- ) + over t "was-compiled" set-word-prop + "compiled-effect" set-word-prop ; + : (compile) ( word -- ) dup compiling? not over compound? and [ [ dup compile-begins - dup dup word-dataflow nip optimize generate - ] curry [ print-error ] recover + dup word-dataflow optimize >r over dup r> generate + ] [ + print-error + dup update-xt dup unchanged-word f + ] recover + 2dup ripple-up save-effect ] [ drop ] if ; -: finish-compilation-unit ( assoc -- ) - [ swap add* ] { } assoc>map modify-code-heap ; - : with-compilation-unit ( quot -- ) [ compile-queue set From 07a4022d621b03ad649153e461669c08b056cb8d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Dec 2007 21:18:24 -0500 Subject: [PATCH 10/82] 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); From 3e27a82f8e746d02c930cef08c9dad24c9e918ea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Dec 2007 15:47:10 -0500 Subject: [PATCH 11/82] Fixes --- Makefile | 2 +- core/parser/parser-tests.factor | 22 ++++++++++++++++------ core/parser/parser.factor | 2 +- 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index 4b5d16b9c3..1042731065 100755 --- a/Makefile +++ b/Makefile @@ -140,7 +140,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS) clean: rm -f vm/*.o - rm libfactor.a + rm -f libfactor.a vm/resources.o: windres vm/factor.rs vm/resources.o diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 521aef0577..0c0bbf82d9 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -343,16 +343,26 @@ IN: temporary ] 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? + [ ] [ + "IN: temporary TUPLE: class-fwd-test ;" + "redefining-a-class-3" parse-stream drop ] unit-test [ t ] [ [ - "IN: temporary \\ class-fwd-test TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] catch [ forward-error? ] is? + ] unit-test + + [ ] [ + "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] unit-test + + [ t ] [ + [ + "IN: temporary \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] catch [ forward-error? ] is? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index ca7c4199a8..c51bc74d5f 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -237,7 +237,7 @@ M: no-word summary : forward-reference? ( word -- ? ) { - { [ dup old-definitions get key? not ] [ f ] } + { [ dup old-definitions get key? over old-definitions get key? or not ] [ f ] } { [ dup new-definitions get key? ] [ f ] } { [ dup new-definitions get key? ] [ f ] } { [ t ] [ t ] } From 0052e129fd32b3c7c7fdf48ef015d49570c06302 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 17:18:26 -0500 Subject: [PATCH 12/82] Clean up class definition recording --- core/bootstrap/image/image.factor | 9 +++++-- core/bootstrap/primitives.factor | 4 +++ core/cpu/x86/assembler/assembler.factor | 2 +- core/definitions/definitions-docs.factor | 7 +---- core/definitions/definitions.factor | 27 +++++++++++++------ core/parser/parser-docs.factor | 2 +- core/parser/parser-tests.factor | 14 +++++----- core/parser/parser.factor | 23 +++++++--------- core/source-files/source-files-docs.factor | 2 +- core/source-files/source-files.factor | 8 +++--- core/syntax/syntax.factor | 4 +-- .../help/definitions/definitions-tests.factor | 4 +-- extra/help/syntax/syntax.factor | 2 +- 13 files changed, 61 insertions(+), 47 deletions(-) mode change 100644 => 100755 core/cpu/x86/assembler/assembler.factor mode change 100644 => 100755 extra/help/definitions/definitions-tests.factor mode change 100644 => 100755 extra/help/syntax/syntax.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 18efb74fa9..a738c157c3 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -351,12 +351,18 @@ M: curry ' : emit-words ( -- ) all-words [ emit-word ] each ; +: fix-source-files + [ + clone dup source-file-definitions H{ } clone 2array + over set-source-file-definitions + ] assoc-map ; + : emit-global ( -- ) [ { dictionary source-files typemap builtins class : make-image ( arch -- ) [ - [ 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 index 12248b8361..33b1b05be4 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -19,7 +19,11 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set "resource:core/bootstrap/syntax.factor" parse-file + H{ } clone dictionary set +H{ } clone changed-words set +[ drop ] recompile-hook set + call ! Create some empty vocabs where the below primitives and diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor old mode 100644 new mode 100755 index bb5e13613c..15b0d57f4f --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generator generator.fixup io.binary kernel +USING: arrays generator.fixup io.binary kernel combinators kernel.private math namespaces parser sequences words system ; IN: cpu.x86.assembler diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index b771306d9b..2a698ca3fa 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -88,12 +88,7 @@ HELP: redefine-error { $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) +HELP: remember-definition { $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 diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index d21d689975..104dd3c09e 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -54,26 +54,37 @@ TUPLE: redefine-error def ; \ redefine-error construct-boa { { "Continue" t } } throw-restarts drop ; -: redefinition? ( definition -- ? ) - new-definitions get key? ; +: add-once ( key assoc -- ) + 2dup key? [ drop redefine-error ] when dupd set-at ; -: (save-location) ( definition loc -- ) - over redefinition? [ over redefine-error ] when - over set-where - dup new-definitions get set-at ; +: (remember-definition) ( definition loc assoc -- ) + >r over set-where r> add-once ; + +: remember-definition ( definition loc -- ) + new-definitions get first (remember-definition) ; + +: remember-class ( class loc -- ) + new-definitions get second (remember-definition) ; TUPLE: forward-error word ; : forward-error ( word -- ) \ forward-error construct-boa throw ; +: forward-reference? ( word -- ? ) + dup old-definitions get assoc-stack + [ new-definitions get assoc-stack not ] + [ drop f ] if ; + SYMBOL: recompile-hook +: ( -- pair ) { H{ } H{ } } [ clone ] map ; + : with-compilation-unit ( quot -- new-defs ) [ H{ } clone changed-words set - H{ } clone new-definitions set - old-definitions off + new-definitions set + old-definitions set call changed-words get keys recompile-hook get call ] with-scope ; inline diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 446add5678..4dce1bd455 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -229,7 +229,7 @@ HELP: 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) } "." } ; +{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ; HELP: save-location { $values { "definition" "a definition specifier" } } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 0c0bbf82d9..57ff831eca 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -141,7 +141,7 @@ IN: temporary "IN: temporary : smudge-me ;" "foo" parse-stream drop - "foo" source-file source-file-definitions assoc-size + "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test @@ -158,21 +158,21 @@ IN: temporary "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" parse-stream drop - "foo" source-file source-file-definitions assoc-size + "foo" source-file source-file-definitions first assoc-size ] unit-test [ 1 ] [ "IN: temporary USING: arrays ; M: array smudge-me ;" "bar" parse-stream drop - "bar" source-file source-file-definitions assoc-size + "bar" source-file source-file-definitions first assoc-size ] unit-test [ 2 ] [ "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" parse-stream drop - "foo" source-file source-file-definitions assoc-size + "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ @@ -217,7 +217,7 @@ IN: temporary [ t ] [ [ - "IN: temporary : x ; : y 3 throw ; parsing y" + "IN: temporary : x ; : y 3 throw ; this is an error" "a" parse-stream ] catch parse-error? ] unit-test @@ -376,9 +376,9 @@ IN: temporary : ~c ; : ~d ; - H{ { ~a ~a } { ~c ~c } { ~d ~d } } old-definitions set + { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set - H{ { ~d ~d } } new-definitions set + { H{ { ~d ~d } } H{ } } new-definitions set [ V{ ~b } { ~a } { ~a ~c } ] [ smudged-usage diff --git a/core/parser/parser.factor b/core/parser/parser.factor index c51bc74d5f..e954b55782 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -20,7 +20,10 @@ TUPLE: lexer text line column ; [ >r source-file-path r> 2array ] [ 2drop f ] if ; : save-location ( definition -- ) - location (save-location) ; + location remember-definition ; + +: save-class-location ( class -- ) + location remember-class ; SYMBOL: parser-notes @@ -217,7 +220,7 @@ PREDICATE: unexpected unexpected-eof : CREATE-CLASS ( -- word ) scan in get create - dup save-location + dup save-class-location dup predicate-word save-location ; : word-restarts ( possibilities -- restarts ) @@ -235,14 +238,6 @@ M: no-word summary swap words-named word-restarts throw-restarts dup word-vocabulary (use+) ; -: forward-reference? ( word -- ? ) - { - { [ dup old-definitions get key? over old-definitions get key? or 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? [ drop @@ -270,7 +265,8 @@ M: staging-violation summary "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 + dup + new-definitions get first key? [ staging-violation ] when execute ; : parse-step ( accum end -- accum ? ) @@ -380,9 +376,10 @@ SYMBOL: bootstrap-syntax file get source-file-path = ] assoc-subset ; +: removed-definitions ( -- definitions ) new-definitions get old-definitions get [ first2 union ] 2apply diff ; + : smudged-usage ( -- usages referenced removed ) - new-definitions get old-definitions get diff filter-moved - keys [ + removed-definitions filter-moved keys [ outside-usages [ empty? swap pathname? or not ] assoc-subset dup values concat prune swap keys diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 742d12fff3..66b56e6168 100755 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -37,7 +37,7 @@ HELP: source-file { { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." } { { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." } { { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." } - { { $link source-file-definitions } " - an assoc whose keys are definitions defined in this source file." } + { { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" } } } ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 30514e5aee..e1c6b0e2b6 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -58,7 +58,9 @@ uses definitions ; new-definitions get swap set-source-file-definitions ; : ( path -- source-file ) - { set-source-file-path } \ source-file construct ; + + { set-source-file-path set-source-file-definitions } + \ source-file construct ; : source-file ( path -- source-file ) source-files get [ ] cache ; @@ -74,13 +76,13 @@ M: pathname where pathname-string 1 2array ; : forget-source ( path -- ) dup source-file dup unxref-source - source-file-definitions keys forget-all + source-file-definitions [ keys forget-all ] each 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 + dup source-file-definitions new-definitions get [ union ] 2map swap set-source-file-definitions ; SYMBOL: file diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 4c55dede64..f3f4adc62c 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -95,7 +95,7 @@ IN: bootstrap.syntax "DEFER:" [ scan in get create - dup old-definitions get delete-at + dup old-definitions get first delete-at set-word ] define-syntax @@ -128,7 +128,7 @@ IN: bootstrap.syntax location >r scan-word bootstrap-word scan-word [ parse-definition -rot define-method ] 2keep - 2array r> (save-location) + 2array r> remember-definition ] define-syntax "UNION:" [ diff --git a/extra/help/definitions/definitions-tests.factor b/extra/help/definitions/definitions-tests.factor old mode 100644 new mode 100755 index 6f6703258f..a07789ddfd --- a/extra/help/definitions/definitions-tests.factor +++ b/extra/help/definitions/definitions-tests.factor @@ -12,7 +12,7 @@ IN: temporary "IN: temporary USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop - "foo" source-file source-file-definitions assoc-size + "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ "hello" articles get key? ] unit-test @@ -25,7 +25,7 @@ IN: temporary "IN: temporary USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" parse-stream drop - "foo" source-file source-file-definitions assoc-size + "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ "hello" articles get key? ] unit-test diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor old mode 100644 new mode 100755 index a1acd6a49d..6d287de60f --- a/extra/help/syntax/syntax.factor +++ b/extra/help/syntax/syntax.factor @@ -13,7 +13,7 @@ IN: help.syntax : ARTICLE: location >r \ ; parse-until >array [ first2 ] keep 2 tail
- over add-article >link r> (save-location) ; parsing + over add-article >link r> remember-definition ; parsing : ABOUT: scan-word dup parsing? [ From 02b509a1d4bc0a6653616dd2f2caf5d81f5456a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 17:18:46 -0500 Subject: [PATCH 13/82] Remove dead code --- core/classes/classes.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 195ba23226..d9f2c71f74 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -277,9 +277,3 @@ M: object class type type>class ; 2 slot { word } declare ; inline PRIVATE> - -! A dummy -TUPLE: class-definition ; - -: ( word -- defspec ) - class-definition construct-delegate ; From 41fc4ea84efa2d846bf814d226fb7ad77f971730 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 17:32:41 -0500 Subject: [PATCH 14/82] forget-vocab and forget-source now call with-compilation-unit --- core/classes/classes-tests.factor | 2 +- core/compiler/test/redefine.factor | 2 +- core/cpu/x86/bootstrap.factor | 0 core/definitions/definitions-tests.factor | 15 ++++++++++++--- core/listener/listener-tests.factor | 8 ++++++-- core/source-files/source-files.factor | 10 ++++++---- core/tuples/tuples-tests.factor | 18 +++++++++++------- core/vocabs/loader/loader-tests.factor | 16 ++++++++-------- core/vocabs/vocabs.factor | 6 ++++-- extra/help/crossref/crossref-tests.factor | 4 +++- extra/tools/test/test.factor | 0 extra/ui/tools/operations/operations.factor | 5 ++++- extra/ui/traverse/traverse-tests.factor | 2 +- 13 files changed, 57 insertions(+), 31 deletions(-) mode change 100644 => 100755 core/classes/classes-tests.factor mode change 100644 => 100755 core/cpu/x86/bootstrap.factor mode change 100644 => 100755 core/definitions/definitions-tests.factor mode change 100644 => 100755 core/listener/listener-tests.factor mode change 100644 => 100755 core/tuples/tuples-tests.factor mode change 100644 => 100755 core/vocabs/loader/loader-tests.factor mode change 100644 => 100755 core/vocabs/vocabs.factor mode change 100644 => 100755 extra/help/crossref/crossref-tests.factor mode change 100644 => 100755 extra/tools/test/test.factor mode change 100644 => 100755 extra/ui/traverse/traverse-tests.factor diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor old mode 100644 new mode 100755 index dd18d32029..c8bc331af7 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -137,7 +137,7 @@ INSTANCE: integer mx1 [ mx1 ] [ array integer class-or ] unit-test -\ mx1 forget +[ \ mx1 forget ] with-compilation-unit [ f ] [ array integer class-or mx1 = ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index c54b09d0e8..e61ba2e762 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -32,7 +32,7 @@ parse-hook get [ [ f ] [ \ bar changed-words get key? ] unit-test [ ] [ \ bar [ 1 2 3 ] define-compound ] unit-test [ t ] [ \ bar changed-words get key? ] unit-test - [ ] [ \ bar forget ] unit-test + [ ] [ [ \ bar forget ] with-compilation-unit ] unit-test [ f ] [ \ bar changed-words get key? ] unit-test : xy ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor old mode 100644 new mode 100755 diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor old mode 100644 new mode 100755 index 14d1c03be3..f2a9d74aa5 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -11,7 +11,11 @@ generic-1 T{ combination-1 } define-generic [ ] object \ generic-1 define-method -[ ] [ { combination-1 { object generic-1 } } forget-all ] unit-test +[ ] [ + [ + { combination-1 { object generic-1 } } forget-all + ] with-compilation-unit +] unit-test GENERIC: some-generic @@ -34,6 +38,11 @@ M: some-class some-generic ; TUPLE: another-class some-generic ; [ ] [ - { some-generic some-class { another-class some-generic } } - forget-all + [ + { + some-generic + some-class + { another-class some-generic } + } forget-all + ] with-compilation-unit ] unit-test diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor old mode 100644 new mode 100755 index 47bb00b159..06b634769e --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -26,11 +26,15 @@ IN: temporary ] unit-test ] with-scope -[ ] [ "vocabs.loader.test.c" forget-vocab ] unit-test +[ ] [ + "vocabs.loader.test.c" forget-vocab +] unit-test [ "USE: vocabs.loader.test.c" parse-interactive ] unit-test-fails -[ ] [ "vocabs.loader.test.c" forget-vocab ] unit-test +[ ] [ + "vocabs.loader.test.c" forget-vocab +] unit-test diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index e1c6b0e2b6..646322fc8f 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -74,10 +74,12 @@ uses definitions ; M: pathname where pathname-string 1 2array ; : forget-source ( path -- ) - dup source-file - dup unxref-source - source-file-definitions [ keys forget-all ] each - source-files get delete-at ; + [ + dup source-file + dup unxref-source + source-file-definitions [ keys forget-all ] each + source-files get delete-at + ] with-compilation-unit ; M: pathname forget pathname-string forget-source ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor old mode 100644 new mode 100755 index 0ac62912b7..e6630778e3 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -120,11 +120,13 @@ TUPLE: yo-momma ; [ f ] [ \ generic? ] unit-test ! Test forget -[ t ] [ \ yo-momma class? ] unit-test -[ ] [ \ yo-momma forget ] unit-test -[ f ] [ \ yo-momma typemap get values memq? ] unit-test +[ + [ t ] [ \ yo-momma class? ] unit-test + [ ] [ \ yo-momma forget ] unit-test + [ f ] [ \ yo-momma typemap get values memq? ] unit-test -[ f ] [ \ yo-momma interned? ] unit-test + [ f ] [ \ yo-momma interned? ] unit-test +] with-compilation-unit TUPLE: loc-recording ; @@ -140,9 +142,11 @@ M: forget-robustness forget-robustness-generic ; M: integer forget-robustness-generic ; -[ ] [ \ forget-robustness-generic forget ] unit-test -[ ] [ \ forget-robustness forget ] unit-test -[ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test +[ + [ ] [ \ forget-robustness-generic forget ] unit-test + [ ] [ \ forget-robustness forget ] unit-test + [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test +] with-compilation-unit ! rapido found this one GENERIC# m1 0 ( s n -- n ) diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor old mode 100644 new mode 100755 index 1c86f22d6c..c78d3b378f --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -6,7 +6,9 @@ parser source-files words assocs tuples definitions debugger ; ! This vocab should not exist, but just in case... -[ ] [ "vocabs.loader.test" forget-vocab ] unit-test +[ ] [ + "vocabs.loader.test" forget-vocab +] unit-test [ T{ vocab-link f "vocabs.loader.test" } ] [ "vocabs.loader.test" f >vocab-link ] unit-test @@ -78,12 +80,12 @@ IN: temporary 0 "count-me" set-global -[ ] [ "vocabs.loader.test.b" forget-vocab ] unit-test +[ ] [ + "vocabs.loader.test.b" forget-vocab +] unit-test [ ] [ - "vocabs.loader.test.b" vocab-files [ - forget-source - ] each + "vocabs.loader.test.b" vocab-files [ forget-source ] each ] unit-test [ "vocabs.loader.test.b" require ] unit-test-fails @@ -101,9 +103,7 @@ IN: temporary [ t ] [ "fred" "vocabs.loader.test.b" lookup compound? ] unit-test [ ] [ - "vocabs.loader.test.b" vocab-files [ - forget-source - ] each + "vocabs.loader.test.b" vocab-files [ forget-source ] each ] unit-test [ ] [ "vocabs.loader.test.b" refresh ] unit-test diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor old mode 100644 new mode 100755 index 0d3475c951..864f1820ef --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -76,8 +76,10 @@ SYMBOL: load-vocab-hook [ ] subset ; : forget-vocab ( vocab -- ) - dup vocab-words values forget-all - vocab-name dictionary get delete-at ; + [ + dup vocab-words values forget-all + vocab-name dictionary get delete-at + ] with-compilation-unit ; : child-vocab? ( prefix name -- ? ) 2dup = pick empty? or diff --git a/extra/help/crossref/crossref-tests.factor b/extra/help/crossref/crossref-tests.factor old mode 100644 new mode 100755 index 444c7ca381..619c58b018 --- a/extra/help/crossref/crossref-tests.factor +++ b/extra/help/crossref/crossref-tests.factor @@ -18,7 +18,9 @@ io.streams.string continuations debugger ; [ "foo" ] [ "foo" "temporary" lookup article-parent ] unit-test -[ ] [ "foo" "temporary" lookup forget ] unit-test +[ ] [ + [ "foo" "temporary" lookup forget ] with-compilation-unit +] unit-test [ ] [ "IN: temporary USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor old mode 100644 new mode 100755 diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index a65228db52..8ac7ec710a 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -74,7 +74,10 @@ UNION: definition word method-spec link vocab vocab-link ; { +listener+ t } } define-operation -[ definition? ] \ forget H{ } define-operation +: com-forget ( defspec -- ) + [ forget ] with-compilation-unit ; + +[ definition? ] \ com-forget H{ } define-operation ! Words [ word? ] \ insert-word H{ diff --git a/extra/ui/traverse/traverse-tests.factor b/extra/ui/traverse/traverse-tests.factor old mode 100644 new mode 100755 index 96eaed6f10..fd5bc6d8ec --- a/extra/ui/traverse/traverse-tests.factor +++ b/extra/ui/traverse/traverse-tests.factor @@ -62,4 +62,4 @@ M: object (flatten-tree) , ; { 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range ] unit-test -{ array gadget-children } forget +[ { array gadget-children } forget ] with-compilation-unit From e2c86aab4d86390971c3fcefb1616249e2c55cff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 17:33:04 -0500 Subject: [PATCH 15/82] Remove dead code --- core/compiler/batch/batch.factor | 50 -------------------------------- 1 file changed, 50 deletions(-) delete mode 100755 core/compiler/batch/batch.factor diff --git a/core/compiler/batch/batch.factor b/core/compiler/batch/batch.factor deleted file mode 100755 index 13d0295e9e..0000000000 --- a/core/compiler/batch/batch.factor +++ /dev/null @@ -1,50 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces dlists kernel words inference.backend -optimizer arrays definitions sequences assocs -continuations generator compiler ; -IN: compiler.batch - -: with-compilation-unit ( quot -- ) - H{ } clone - [ compiled-xts swap with-variable ] keep - [ swap add* ] { } assoc>map modify-code-heap ; - -: compile-batch ( words -- ) - [ [ (compile) ] curry [ print-error ] recover ] each ; - -SYMBOL: compile-queue - -: queue-compile ( word -- ) - compile-queue get push-front ; - -: compiled-usage ( word -- seq ) - #! XXX - usage [ word? ] subset ; - -: ripple-up ( effect word -- ) - tuck "compiled-effect" word-prop = - [ drop ] [ compiled-usage [ queue-compile ] each ] if ; - -: save-effect ( effect word -- ) - swap "compiled-effect" set-word-prop ; - -: add-compiled ( word -- ) - >r f f f f f r> compile-results get set-at ; - -: compile-1 ( word -- ) - dup compile-results get at [ drop ] [ - [ [ word-dataflow drop ] [ 2drop f ] recover ] keep - 2dup ripple-up - tuck save-effect - add-compiled - ] if ; - -: compile-batch ( words -- ) - [ - compile-queue set - [ queue-compile ] each - H{ } clone compile-results set - compile-queue get [ compile-1 ] dlist-slurp - compile-results get - ] with-scope ; From 6814e07f491dab7872c310cc7574e82ec1e832c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 19:40:09 -0500 Subject: [PATCH 16/82] Unit test fixes --- core/bootstrap/image/image.factor | 8 +--- core/compiler/compiler-docs.factor | 9 ---- core/compiler/compiler.factor | 11 +++-- core/compiler/test/alien.factor | 6 --- core/definitions/definitions-tests.factor | 6 ++- core/definitions/definitions.factor | 4 +- core/generator/generator.factor | 1 - core/generic/generic-tests.factor | 6 ++- core/inference/inference-docs.factor | 8 ++++ core/inference/inference.factor | 7 +-- core/listener/listener-tests.factor | 24 ++++++---- core/listener/listener.factor | 9 ++-- core/parser/parser-tests.factor | 8 ++++ core/parser/parser.factor | 2 +- core/prettyprint/prettyprint-tests.factor | 8 ++-- core/source-files/source-files.factor | 16 +++---- core/tuples/tuples-tests.factor | 53 +++++++++------------- core/vocabs/loader/loader-tests.factor | 6 ++- core/vocabs/loader/test/a/a.factor | 4 +- core/vocabs/loader/test/b/b.factor | 3 +- core/vocabs/vocabs.factor | 13 +++--- core/words/words-docs.factor | 9 ++++ core/words/words-tests.factor | 31 ++++++++++--- core/words/words.factor | 6 ++- extra/cocoa/subclassing/subclassing.factor | 2 +- 25 files changed, 144 insertions(+), 116 deletions(-) mode change 100644 => 100755 core/inference/inference-docs.factor mode change 100644 => 100755 core/vocabs/loader/test/a/a.factor mode change 100644 => 100755 core/vocabs/loader/test/b/b.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index a738c157c3..5e3ba5b85e 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -351,18 +351,12 @@ M: curry ' : emit-words ( -- ) all-words [ emit-word ] each ; -: fix-source-files - [ - clone dup source-file-definitions H{ } clone 2array - over set-source-file-definitions - ] assoc-map ; - : emit-global ( -- ) [ { dictionary source-files typemap builtins classalist modify-code-heap ] with-scope ; inline : compile-quot ( quot -- word ) - [ gensym dup rot define-compound ] with-compilation-unit ; + [ define-temp ] with-compilation-unit ; : compile-call ( quot -- ) compile-quot execute ; : compile-all ( -- ) - all-words compile-batch ; + all-words compile ; diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index 8358709590..e737a76e1e 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -99,12 +99,6 @@ unit-test "int" { "int" "int" "int" "int" } "stdcall" alien-indirect data-gc ; -! This is a hack -- words are compiled before top-level forms -! run. - -DEFER: >> delimiter -: << \ >> parse-until >quotation call ; parsing - << "f-stdcall" f "stdcall" add-library >> [ f ] [ "f-stdcall" load-library ] unit-test diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index f2a9d74aa5..4f79cd3f54 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -7,9 +7,11 @@ M: combination-1 perform-combination 2drop { } [ ] each [ ] ; SYMBOL: generic-1 -generic-1 T{ combination-1 } define-generic +[ + generic-1 T{ combination-1 } define-generic -[ ] object \ generic-1 define-method + [ ] object \ generic-1 define-method +] with-compilation-unit [ ] [ [ diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 104dd3c09e..ec21488efc 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -85,6 +85,6 @@ SYMBOL: recompile-hook H{ } clone changed-words set new-definitions set old-definitions set - call - changed-words get keys recompile-hook get call + [ changed-words get keys recompile-hook get call ] [ ] + cleanup ] with-scope ; inline diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0c63f74d64..048b853049 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -22,7 +22,6 @@ SYMBOL: compiled-xts : compiling? ( word -- ? ) { { [ dup compiled-xts get key? ] [ drop t ] } - { [ dup word-changed? ] [ drop f ] } { [ t ] [ compiled? ] } } cond ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 76b9934586..a66e24956e 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -184,7 +184,11 @@ M: debug-combination perform-combination SYMBOL: redefinition-test-generic -redefinition-test-generic T{ debug-combination } define-generic +[ + redefinition-test-generic + T{ debug-combination } + define-generic +] with-compilation-unit TUPLE: redefinition-test-tuple ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor old mode 100644 new mode 100755 index b9ac8ce3a8..5a9c306abf --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -139,3 +139,11 @@ HELP: dataflow-with { $values { "quot" "a quotation" } { "stack" "a vector" } { "dataflow" "a dataflow node" } } { $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; + +HELP: forget-errors +{ $description "Removes markers indicating which words do not have stack effects." +$nl +"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." } +{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:" +{ $code "forget-errors" } +"Subsequent invocations of the compiler will consider all words for compilation." } ; diff --git a/core/inference/inference.factor b/core/inference/inference.factor index f89bfa85df..9588976e50 100755 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -3,7 +3,8 @@ IN: inference USING: inference.backend inference.dataflow inference.known-words inference.transforms inference.errors -sequences prettyprint io effects kernel namespaces quotations ; +sequences prettyprint io effects kernel namespaces quotations +words vocabs ; GENERIC: infer ( quot -- effect ) @@ -26,5 +27,5 @@ M: callable dataflow-with f infer-quot ] with-infer nip ; -: forget-errors ( seq -- ) - [ f "no-effect" set-word-prop ] each ; +: forget-errors ( -- ) + all-words [ f "no-effect" set-word-prop ] each ; diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 06b634769e..2e5b6ccb1c 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -1,11 +1,14 @@ -USING: io io.streams.string listener tools.test parser -math namespaces continuations vocabs ; +USING: io io.streams.string io.streams.duplex listener +tools.test parser math namespaces continuations vocabs kernel ; IN: temporary : hello "Hi" print ; parsing +: parse-interactive ( string -- quot ) + stream-read-quot ; + [ [ ] ] [ - "USE: temporary hello" parse-interactive + "USE: temporary hello" parse-interactive ] unit-test [ @@ -17,11 +20,10 @@ IN: temporary [ "cont" set [ - "\\ + 1 2 3 4" - - parse-interactive "cont" get continue-with + "\\ + 1 2 3 4" parse-interactive + "cont" get continue-with ] catch - ":1" eval + "USE: debugger :1" eval ] callcc1 ] unit-test ] with-scope @@ -31,10 +33,14 @@ IN: temporary ] unit-test [ - "USE: vocabs.loader.test.c" - parse-interactive + "USE: vocabs.loader.test.c" parse-interactive ] unit-test-fails [ ] [ "vocabs.loader.test.c" forget-vocab ] unit-test + +[ ] [ + "IN: temporary : hello\n\"world\" ;" parse-interactive + drop +] unit-test diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 709a03ee27..151b08151f 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -15,7 +15,9 @@ SYMBOL: listener-hook GENERIC: stream-read-quot ( stream -- quot/f ) : read-quot-step ( lines -- quot/f ) - [ parse-lines ] catch { + [ + [ parse-lines in get ] with-compilation-unit in set + ] catch { { [ dup delegate unexpected-eof? ] [ 2drop f ] } { [ dup not ] [ drop ] } { [ t ] [ rethrow ] } @@ -36,10 +38,7 @@ M: line-reader stream-read-quot 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 ; +: read-quot ( -- quot ) stdio get stream-read-quot ; : bye ( -- ) quit-flag on ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 57ff831eca..f6d37af7b0 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -385,3 +385,11 @@ IN: temporary natural-sort ] unit-test ] with-scope + +[ ] [ + "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval +] unit-test + +[ t ] [ + "foo?" "temporary" lookup word eq? +] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e954b55782..1d140ac3b6 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -221,7 +221,7 @@ PREDICATE: unexpected unexpected-eof : CREATE-CLASS ( -- word ) scan in get create dup save-class-location - dup predicate-word save-location ; + dup predicate-word dup set-word save-location ; : word-restarts ( possibilities -- restarts ) natural-sort [ diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 7315b3f2e1..2d959528ed 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -113,10 +113,10 @@ unit-test use [ clone ] change [ - parse-lines drop - [ - "USE: temporary \\ " swap " see" 3append eval - ] string-out "\n" split 1 head* + [ parse-fresh drop ] with-compilation-unit + [ + "temporary" lookup see + ] string-out "\n" split 1 head* ] keep = ] with-scope ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 646322fc8f..d715fd0c95 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -73,15 +73,15 @@ uses definitions ; M: pathname where pathname-string 1 2array ; -: forget-source ( path -- ) - [ - dup source-file - dup unxref-source - source-file-definitions [ keys forget-all ] each - source-files get delete-at - ] with-compilation-unit ; +M: pathname forget + pathname-string + dup source-file + dup unxref-source + source-file-definitions [ keys forget-all ] each + source-files get delete-at ; -M: pathname forget pathname-string forget-source ; +: forget-source ( path -- ) + [ forget ] with-compilation-unit ; : rollback-source-file ( source-file -- ) dup source-file-definitions new-definitions get [ union ] 2map diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index e6630778e3..e21d21813a 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -45,7 +45,7 @@ C: point 100 200 "p" set ! Use eval to sequence parsing explicitly -"IN: temporary TUPLE: point x y z ; do-parse-hook" eval +"IN: temporary TUPLE: point x y z ;" eval [ 100 ] [ "p" get point-x ] unit-test [ 200 ] [ "p" get point-y ] unit-test @@ -53,7 +53,7 @@ C: point 300 "p" get "set-point-z" "temporary" lookup execute -"IN: temporary TUPLE: point z y ; do-parse-hook" eval +"IN: temporary TUPLE: point z y ;" eval [ "p" get point-x ] unit-test-fails [ 200 ] [ "p" get point-y ] unit-test @@ -216,46 +216,37 @@ SYMBOL: not-a-tuple-class [ not-a-tuple-class construct-boa ] unit-test-fails [ not-a-tuple-class construct-empty ] unit-test-fails -! Reshaping bug. It's only an issue when optimizer compiler is -! enabled. -parse-hook get [ - TUPLE: erg's-reshape-problem a b c ; +TUPLE: erg's-reshape-problem a b c ; - C: erg's-reshape-problem +C: erg's-reshape-problem - [ ] [ - "IN: temporary TUPLE: erg's-reshape-problem a b c d ;" eval - ] unit-test +[ ] [ + ! hasn't been recompiled yet, so + ! we just created a tuple using an obsolete layout + "IN: temporary USE: namespaces TUPLE: erg's-reshape-problem a b c d ; 1 2 3 \"a\" set" eval +] unit-test +[ 1 2 ] [ + ! that's ok, but... this shouldn't fail: + "IN: temporary TUPLE: erg's-reshape-problem a b d c ;" eval - [ 1 2 ] [ - ! hasn't been recompiled yet, so - ! we just created a tuple using an obsolete layout - 1 2 3 - - ! that's ok, but... this shouldn't fail: - "IN: temporary TUPLE: erg's-reshape-problem a b d c ;" eval - - { erg's-reshape-problem-a erg's-reshape-problem-b } - get-slots - ] unit-test -] when + "a" get + { erg's-reshape-problem-a erg's-reshape-problem-b } + get-slots +] unit-test ! We want to make sure constructors are recompiled when ! tuples are reshaped : cons-test-1 \ erg's-reshape-problem construct-empty ; : cons-test-2 \ erg's-reshape-problem construct-boa ; : cons-test-3 - { erg's-reshape-problem-a } + { set-erg's-reshape-problem-a } \ erg's-reshape-problem construct ; "IN: temporary TUPLE: erg's-reshape-problem a b c d e f ;" eval -[ t ] [ - { - - cons-test-1 - cons-test-2 - cons-test-3 - } [ changed-words get key? ] all? -] unit-test +[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test + +[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test + +[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index c78d3b378f..8a4d17c185 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -63,7 +63,7 @@ IN: temporary "resource:core/vocabs/loader/test/a/a.factor" source-file source-file-definitions dup USE: prettyprint . "v-l-t-a-hello" "vocabs.loader.test.a" lookup dup . - swap key? + swap first key? ] unit-test ] times @@ -93,7 +93,9 @@ IN: temporary [ 1 ] [ "count-me" get-global ] unit-test [ ] [ - "bob" "vocabs.loader.test.b" create [ ] define-compound + [ + "bob" "vocabs.loader.test.b" create [ ] define-compound + ] with-compilation-unit ] unit-test [ ] [ "vocabs.loader.test.b" refresh ] unit-test diff --git a/core/vocabs/loader/test/a/a.factor b/core/vocabs/loader/test/a/a.factor old mode 100644 new mode 100755 index d3f4dd9efd..03a2f8a091 --- a/core/vocabs/loader/test/a/a.factor +++ b/core/vocabs/loader/test/a/a.factor @@ -1,9 +1,7 @@ USING: namespaces parser ; IN: vocabs.loader.test.a -: COUNT-ME global [ "count-me" inc ] bind ; parsing - -COUNT-ME +<< global [ "count-me" inc ] bind >> : v-l-t-a-hello 4 ; diff --git a/core/vocabs/loader/test/b/b.factor b/core/vocabs/loader/test/b/b.factor old mode 100644 new mode 100755 index 113f7af667..8bd75bfc84 --- a/core/vocabs/loader/test/b/b.factor +++ b/core/vocabs/loader/test/b/b.factor @@ -1,7 +1,6 @@ USING: namespaces ; IN: vocabs.loader.test.b -: COUNT-ME global [ "count-me" inc ] bind ; parsing -COUNT-ME +<< global [ "count-me" inc ] bind >> : fred bob ; \ No newline at end of file diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 864f1820ef..861a977891 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -75,12 +75,6 @@ SYMBOL: load-vocab-hook [ vocab-words at ] curry* map [ ] subset ; -: forget-vocab ( vocab -- ) - [ - dup vocab-words values forget-all - vocab-name dictionary get delete-at - ] with-compilation-unit ; - : child-vocab? ( prefix name -- ? ) 2dup = pick empty? or [ 2drop t ] [ swap CHAR: . add head? ] if ; @@ -98,4 +92,9 @@ M: vocab-link vocab-name vocab-link-name ; UNION: vocab-spec vocab vocab-link ; -M: vocab-spec forget vocab-name forget-vocab ; +M: vocab-spec forget + dup vocab-words values forget-all + vocab-name dictionary get delete-at ; + +: forget-vocab ( vocab -- ) + [ f >vocab-link forget ] with-compilation-unit ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 520e7e00b4..14e3a48514 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -337,6 +337,15 @@ HELP: define-declared { $description "Defines a compound word and declares its stack effect." } { $side-effects "word" } ; +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: quot-uses { $values { "quot" quotation } { "assoc" "an assoc with words as keys" } } { $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ; diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 1a118fd705..82277be78c 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -4,8 +4,10 @@ vocabs continuations ; IN: temporary [ 4 ] [ - "poo" "scratchpad" create [ 2 2 + ] define-compound - "poo" "scratchpad" lookup execute + [ + "poo" "temporary" create [ 2 2 + ] define-compound + ] with-compilation-unit + "poo" "temporary" lookup execute ] unit-test [ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test @@ -88,14 +90,23 @@ FORGET: another-forgotten FORGET: foe ! xref should not retain references to gensyms -gensym [ * ] define-compound +[ ] [ + [ gensym [ * ] define-compound ] with-compilation-unit +] unit-test [ t ] [ \ * usage [ word? ] subset [ interned? not ] subset empty? ] unit-test DEFER: calls-a-gensym -\ calls-a-gensym gensym dup "x" set 1quotation define-compound +[ ] [ + [ + \ calls-a-gensym + gensym dup "x" set 1quotation + define-compound + ] with-compilation-unit +] unit-test + [ f ] [ "x" get crossref get at ] unit-test ! more xref buggery @@ -130,10 +141,18 @@ DEFER: x SYMBOL: quot-uses-a SYMBOL: quot-uses-b -quot-uses-a [ 2 3 + ] define-compound +[ ] [ + [ + quot-uses-a [ 2 3 + ] define-compound + ] with-compilation-unit +] unit-test [ { + } ] [ \ quot-uses-a uses ] unit-test -quot-uses-b 2 [ 3 + ] curry define-compound +[ ] [ + [ + quot-uses-b 2 [ 3 + ] curry define-compound + ] with-compilation-unit +] unit-test [ { + } ] [ \ quot-uses-b uses ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 0491809cb6..28a89d467f 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -102,7 +102,8 @@ PRIVATE> : intern-symbol ( word -- ) dup undefined? [ define-symbol ] [ drop ] if ; -: define-compound ( word def -- ) [ ] like define ; +: define-compound ( word def -- ) + [ ] like define ; : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop @@ -135,6 +136,9 @@ PRIVATE> : gensym ( -- word ) "G:" \ gensym counter number>string append f ; +: define-temp ( quot -- word ) + gensym dup rot define-compound ; + : reveal ( word -- ) dup word-name over word-vocabulary vocab-words set-at ; diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor index 9cc8709e9d..d918bf29ca 100755 --- a/extra/cocoa/subclassing/subclassing.factor +++ b/extra/cocoa/subclassing/subclassing.factor @@ -83,7 +83,7 @@ IN: cocoa.subclassing : prepare-method ( ret types quot -- type imp ) >r [ encode-types ] 2keep r> [ "cdecl" swap 4array % \ alien-callback , - ] [ ] make compile-quot ; + ] [ ] make define-temp ; : prepare-methods ( methods -- methods ) [ first4 prepare-method 3array ] map ; From 7c75697ff3d3bd389127f100d02ce6a8b24c2551 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 20:56:23 -0500 Subject: [PATCH 17/82] Assorted fixes --- core/bootstrap/image/image.factor | 2 -- core/bootstrap/primitives.factor | 4 +++ core/classes/classes-tests.factor | 12 +++----- core/compiler/compiler-docs.factor | 2 +- core/compiler/compiler.factor | 3 +- core/compiler/test/redefine.factor | 43 ----------------------------- core/cpu/x86/bootstrap.factor | 3 +- core/definitions/definitions.factor | 9 ++++-- core/generator/generator.factor | 11 ++------ core/generic/generic.factor | 9 +++--- core/kernel/kernel-tests.factor | 6 ++++ 11 files changed, 33 insertions(+), 71 deletions(-) mode change 100644 => 100755 core/kernel/kernel-tests.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 5e3ba5b85e..20aa3af0be 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -390,8 +390,6 @@ M: curry ' heap-size data-heap-size-offset fixup ; : end-image ( -- ) - "Building generic words..." print flush - all-words [ generic? ] subset [ make-generic ] each "Serializing words..." print flush emit-words "Serializing JIT data..." print flush diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 33b1b05be4..f1d86deba2 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -22,6 +22,7 @@ crossref off H{ } clone dictionary set H{ } clone changed-words set +H{ } clone changed-generics set [ drop ] recompile-hook set call @@ -608,3 +609,6 @@ builtins get num-tags get tail f union-class define-class ! Bump build number "build" "kernel" create build 1+ 1quotation define-compound + +! Make generics +changed-generics get keys [ make-generic ] each diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index c8bc331af7..8e513dfdbd 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -78,9 +78,7 @@ M: union-1 generic-update-test drop "union-1" ; [ union-1 ] [ fixnum float class-or ] unit-test -"IN: temporary UNION: union-1 rational array ;" eval - -do-parse-hook +"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval [ t ] [ bignum union-1 class< ] unit-test [ f ] [ union-1 number class< ] unit-test @@ -88,9 +86,7 @@ do-parse-hook [ object ] [ fixnum float class-or ] unit-test -"IN: temporary PREDICATE: integer union-1 even? ;" eval - -do-parse-hook +"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test @@ -130,7 +126,7 @@ INSTANCE: integer mx1 [ t ] [ mx1 integer class< ] unit-test [ t ] [ mx1 number class< ] unit-test -"INSTANCE: array mx1" eval +"IN: temporary USE: arrays INSTANCE: array mx1" eval [ t ] [ array mx1 class< ] unit-test [ f ] [ mx1 number class< ] unit-test @@ -161,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ quotation redefine-bug-2 class< ] unit-test [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test -"IN: temporary UNION: redefine-bug-1 bignum ;" eval +"IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval [ t ] [ bignum redefine-bug-1 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index cd1ecbdbd7..4f3e07daf1 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -109,5 +109,5 @@ HELP: compile-begins HELP: (compile) { $values { "word" word } } -{ $description "Compile a word. This word recursively calls itself to compile all dependencies." } +{ $description "Compile a single word." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 27a85d1035..b26899b080 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -34,8 +34,7 @@ SYMBOL: compiler-hook dup compile-begins dup word-dataflow optimize >r over dup r> generate ] [ - print-error - dup f compiled-xts get set-at f + print-error f ] recover 2dup ripple-up save-effect ] [ drop ] if ; diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index e61ba2e762..195e4e9cd5 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -3,46 +3,3 @@ 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 - - [ ] [ \ foo [ 1 2 ] define-compound ] unit-test - { 0 2 } [ foo ] unit-test-effect - [ ] [ \ foo compile ] unit-test - [ ] [ \ bar [ foo foo ] define-compound ] unit-test - [ ] [ \ bar compile ] unit-test - [ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test - [ t ] [ \ bar changed-words get key? ] unit-test - [ ] [ recompile ] unit-test - { 0 3 } [ foo ] unit-test-effect - [ f ] [ \ bar changed-words get key? ] unit-test - [ ] [ \ bar [ 1 2 ] define-compound ] unit-test - [ t ] [ \ bar changed-words get key? ] unit-test - [ ] [ recompile ] unit-test - { 0 2 } [ bar ] unit-test-effect - [ f ] [ \ bar changed-words get key? ] unit-test - [ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test - [ f ] [ \ bar changed-words get key? ] unit-test - [ ] [ \ bar [ 1 2 3 ] define-compound ] unit-test - [ t ] [ \ bar changed-words get key? ] unit-test - [ ] [ [ \ bar forget ] with-compilation-unit ] unit-test - [ f ] [ \ bar changed-words get key? ] unit-test - - : xy ; - : yx xy ; - - \ yx compile - - \ xy [ 1 ] define-compound - - [ ] [ recompile ] unit-test - - [ 1 ] [ yx ] unit-test -] when diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 8e371ee823..935ca1bad0 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -21,7 +21,8 @@ big-endian off stack-frame-size PUSH ! save stack frame size xt-reg PUSH ! save XT arg0 PUSH ! save array - stack-reg 4 bootstrap-cells SUB ! reserve space for scan-save + scan-reg PUSH ! initial scan + stack-reg 3 bootstrap-cells SUB ! reserved ] { } make jit-prolog set : advance-scan scan-reg bootstrap-cell ADD ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index ec21488efc..54aa751408 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -45,6 +45,7 @@ M: object redefined* drop ; dup unxref crossref get delete-at ; SYMBOL: changed-words +SYMBOL: changed-generics SYMBOL: old-definitions SYMBOL: new-definitions @@ -77,14 +78,18 @@ TUPLE: forward-error word ; [ drop f ] if ; SYMBOL: recompile-hook +SYMBOL: make-generic-hook : ( -- pair ) { H{ } H{ } } [ clone ] map ; : with-compilation-unit ( quot -- new-defs ) [ H{ } clone changed-words set + H{ } clone changed-generics set new-definitions set old-definitions set - [ changed-words get keys recompile-hook get call ] [ ] - cleanup + [ + changed-generics get keys make-generic-hook get call + changed-words get keys recompile-hook get call + ] [ ] cleanup ] with-scope ; inline diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 048b853049..d38f25d302 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -13,19 +13,14 @@ SYMBOL: compiled-xts : 6array 3array >r 3array r> append ; -: begin-compiling ( word -- ) - f swap compiled-xts get set-at ; - : finish-compiling ( word literals words rel labels code -- ) 6array swap compiled-xts get set-at ; : compiling? ( word -- ? ) - { - { [ dup compiled-xts get key? ] [ drop t ] } - { [ t ] [ compiled? ] } - } cond ; + dup compiled-xts get key? swap compiled? ; : queue-compile ( word -- ) + dup f compiled-xts get set-at compile-queue get push-front ; SYMBOL: compiling-word @@ -46,7 +41,7 @@ t compiled-stack-traces? set-global literal-table get push ; : generate-1 ( word label node quot -- ) - pick begin-compiling [ + [ roll compiling-word set pick compiling-label set init-generator diff --git a/core/generic/generic.factor b/core/generic/generic.factor index d5060827c2..29b357be18 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -28,8 +28,11 @@ M: object perform-combination dup "combination" word-prop perform-combination define-compound ; +[ [ make-generic ] each ] make-generic-hook set-global + : ?make-generic ( word -- ) - [ [ ] define-compound ] [ make-generic ] if-bootstrapping ; + dup compound? [ dup [ ] define-compound ] unless + dup changed-generics get set-at ; : init-methods ( word -- ) dup "methods" word-prop @@ -111,6 +114,4 @@ M: class forget ( class -- ) forget-word ; M: class update-methods ( class -- ) - [ drop ] - [ class-usages implementors* [ make-generic ] each ] - if-bootstrapping ; + class-usages implementors* [ ?make-generic ] each ; diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor old mode 100644 new mode 100755 index ecc1b1c19a..1c4c529749 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -102,3 +102,9 @@ IN: temporary [ 3drop datastack ] unit-test-fails [ ] [ :c ] unit-test + +! Doesn't compile; important +: foo 5 + 0 [ ] each ; + +[ drop foo ] unit-test-fails +[ ] [ :c ] unit-test From bbb89af5a6ae1b7953487462ec65f080f17ee584 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 21:41:46 -0500 Subject: [PATCH 18/82] Get compiler going again, start re-doing redefine tests --- core/bootstrap/compiler/compiler.factor | 2 +- core/compiler/compiler.factor | 35 +++++++++------ core/compiler/test/redefine.factor | 46 +++++++++++++++++++ core/compiler/test/simple.factor | 60 ++++++++++++------------- core/cpu/x86/32/32.factor | 2 +- core/generator/generator-docs.factor | 6 +-- core/generator/generator.factor | 27 ++++++----- 7 files changed, 115 insertions(+), 63 deletions(-) mode change 100644 => 100755 core/compiler/test/simple.factor diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 177632e49e..014586d71c 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -54,4 +54,4 @@ generator command-line vocabs io prettyprint libc ; malloc free memcpy } compile -[ compile-batch ] recompile-hook set-global +[ compile ] recompile-hook set-global diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index b26899b080..35f8283c42 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -29,27 +29,34 @@ SYMBOL: compiler-hook "compiled-effect" set-word-prop ; : (compile) ( word -- ) - dup compiling? not over compound? and [ - [ - dup compile-begins - dup word-dataflow optimize >r over dup r> generate - ] [ - print-error f - ] recover - 2dup ripple-up save-effect - ] [ drop ] if ; + [ + dup compile-begins + dup word-dataflow optimize >r over dup r> generate + ] [ + print-error f + ] recover + 2dup ripple-up save-effect ; + +: delete-any ( assoc -- element ) + [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ; + +: compile-loop ( assoc -- ) + dup assoc-empty? + [ drop ] [ dup delete-any (compile) compile-loop ] if ; : compile ( words -- ) [ - compile-queue set - H{ } clone compiled-xts set + H{ } clone compile-queue set + H{ } clone compiled set [ queue-compile ] each - compile-queue get [ (compile) ] dlist-slurp - compiled-xts get >alist modify-code-heap + compile-queue get compile-loop + compiled get >alist modify-code-heap ] with-scope ; inline : compile-quot ( quot -- word ) - [ define-temp ] with-compilation-unit ; + H{ } clone changed-words [ + define-temp dup 1array compile + ] with-variable ; : compile-call ( quot -- ) compile-quot execute ; diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 195e4e9cd5..21d1bfe87a 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -3,3 +3,49 @@ namespaces parser tools.test words kernel sequences arrays io effects tools.test.inference ; IN: temporary +DEFER: b +DEFER: c + +[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test + +[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test + +{ 0 4 } [ b ] unit-test-effect + +[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test + +[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test + +{ 0 6 } [ b ] unit-test-effect + +\ b word-xt "b-xt" set + +[ ] [ "IN: temporary : c b ;" eval ] unit-test + +[ t ] [ "b-xt" get \ b word-xt = ] unit-test + +\ c word-xt "c-xt" set + +[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test + +[ t ] [ "c-xt" get \ c word-xt = ] unit-test + +[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test + +[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test + +{ 0 4 } [ c ] unit-test-effect + +[ f ] [ "c-xt" get \ c word-xt = ] unit-test + +[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test + +[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test + +[ ] [ "IN: temporary : e d d ;" eval ] unit-test + +[ 3 3 ] [ "USE: temporary e" eval ] unit-test + +[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test + +[ 4 4 ] [ "USE: temporary e" eval ] unit-test diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor old mode 100644 new mode 100755 index cc446dee23..5dc07a4818 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -3,61 +3,59 @@ combinators.private ; IN: temporary ! Test empty word -[ ] [ [ ] compile-1 ] unit-test +[ ] [ [ ] compile-call ] unit-test ! Test literals -[ 1 ] [ [ 1 ] compile-1 ] unit-test -[ 31 ] [ [ 31 ] compile-1 ] unit-test -[ 255 ] [ [ 255 ] compile-1 ] unit-test -[ -1 ] [ [ -1 ] compile-1 ] unit-test -[ 65536 ] [ [ 65536 ] compile-1 ] unit-test -[ -65536 ] [ [ -65536 ] compile-1 ] unit-test -[ "hey" ] [ [ "hey" ] compile-1 ] unit-test +[ 1 ] [ [ 1 ] compile-call ] unit-test +[ 31 ] [ [ 31 ] compile-call ] unit-test +[ 255 ] [ [ 255 ] compile-call ] unit-test +[ -1 ] [ [ -1 ] compile-call ] unit-test +[ 65536 ] [ [ 65536 ] compile-call ] unit-test +[ -65536 ] [ [ -65536 ] compile-call ] unit-test +[ "hey" ] [ [ "hey" ] compile-call ] unit-test ! Calls : no-op ; -[ ] [ [ no-op ] compile-1 ] unit-test -[ 3 ] [ [ no-op 3 ] compile-1 ] unit-test -[ 3 ] [ [ 3 no-op ] compile-1 ] unit-test +[ ] [ [ no-op ] compile-call ] unit-test +[ 3 ] [ [ no-op 3 ] compile-call ] unit-test +[ 3 ] [ [ 3 no-op ] compile-call ] unit-test : bar 4 ; -[ 4 ] [ [ bar no-op ] compile-1 ] unit-test -[ 4 3 ] [ [ no-op bar 3 ] compile-1 ] unit-test -[ 3 4 ] [ [ 3 no-op bar ] compile-1 ] unit-test +[ 4 ] [ [ bar no-op ] compile-call ] unit-test +[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test +[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test [ ] [ no-op ] unit-test ! Conditionals -[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test -[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test -[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test -[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test +[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test +[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test -[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test -[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test +[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test +[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test -[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test -[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test +[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test +[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test -[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test -[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test -[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test -[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test +[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test ! Labels : recursive ( ? -- ) [ f recursive ] when ; inline -[ ] [ t [ recursive ] compile-1 ] unit-test - -\ recursive compile +[ ] [ t [ recursive ] compile-call ] unit-test [ ] [ t recursive ] unit-test ! Make sure error reporting works -[ [ dup ] compile-1 ] unit-test-fails -[ [ drop ] compile-1 ] unit-test-fails +[ [ dup ] compile-call ] unit-test-fails +[ [ drop ] compile-call ] unit-test-fails diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 601a4ae63d..ddc72a0453 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -279,7 +279,7 @@ T{ x86-backend f 4 } compiler-backend set-global "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush - [ sse2? ] compile-1 [ + [ sse2? ] compile-call [ " - yes" print "cpu.x86.sse2" require ] [ diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index b77937205a..558ed2bed8 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -19,13 +19,9 @@ $nl ABOUT: "generator" -HELP: compiled-xts +HELP: compiled { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ; -HELP: compiling? -{ $values { "word" word } { "?" "a boolean" } } -{ $description "Tests if a word is going to be or already is compiled." } ; - 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 d38f25d302..9f3851f8f1 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -4,24 +4,29 @@ USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer prettyprint -quotations sequences system threads words dlists ; +quotations sequences system threads words ; IN: generator SYMBOL: compile-queue - -SYMBOL: compiled-xts +SYMBOL: compiled : 6array 3array >r 3array r> append ; -: finish-compiling ( word literals words rel labels code -- ) - 6array swap compiled-xts get set-at ; +: begin-compiling ( word -- ) + f swap compiled get set-at ; -: compiling? ( word -- ? ) - dup compiled-xts get key? swap compiled? ; +: finish-compiling ( word literals words rel labels code -- ) + 6array swap compiled get set-at ; : queue-compile ( word -- ) - dup f compiled-xts get set-at - compile-queue get push-front ; + { + { [ dup compound? not ] [ drop ] } + { [ dup compiled get key? ] [ drop ] } + { [ t ] [ dup compile-queue get set-at ] } + } cond ; + +: maybe-compile ( word -- ) + dup compiled? [ drop ] [ queue-compile ] if ; SYMBOL: compiling-word @@ -41,7 +46,7 @@ t compiled-stack-traces? set-global literal-table get push ; : generate-1 ( word label node quot -- ) - [ + pick begin-compiling [ roll compiling-word set pick compiling-label set init-generator @@ -124,7 +129,7 @@ M: node generate-node drop iterate-next ; } cond ; : generate-call ( label -- next ) - dup queue-compile + dup maybe-compile end-basic-block tail-call? [ %jump f From 28d6fec55766c5f4caeec6810560aeb975c07e63 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 21:54:45 -0500 Subject: [PATCH 19/82] Getting compiler unit tests to pass --- core/alien/syntax/syntax-docs.factor | 1 - core/bootstrap/compiler/compiler.factor | 17 +- core/bootstrap/stage2.factor | 6 +- core/compiler/compiler-docs.factor | 2 +- core/compiler/compiler.factor | 2 +- core/compiler/test/curry.factor | 48 +-- core/compiler/test/float.factor | 134 +++---- core/compiler/test/ifte.factor | 8 +- core/compiler/test/intrinsics.factor | 491 ++++++++++++------------ core/compiler/test/optimizer.factor | 94 ++--- core/compiler/test/stack-trace.factor | 3 - core/compiler/test/templates.factor | 70 ++-- core/compiler/test/tuples.factor | 12 +- core/generator/generator.factor | 4 +- 14 files changed, 444 insertions(+), 448 deletions(-) mode change 100644 => 100755 core/alien/syntax/syntax-docs.factor mode change 100644 => 100755 core/compiler/test/float.factor mode change 100644 => 100755 core/compiler/test/tuples.factor diff --git a/core/alien/syntax/syntax-docs.factor b/core/alien/syntax/syntax-docs.factor old mode 100644 new mode 100755 index eda7cc6b9f..82f1ea3b78 --- a/core/alien/syntax/syntax-docs.factor +++ b/core/alien/syntax/syntax-docs.factor @@ -38,7 +38,6 @@ $nl { $unchecked-example "LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;" "USE: compiler" - "\\ the_answer compile" "\"the question\" 42 the_answer" "The answer to the question is 42." } } diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 014586d71c..a0d767a387 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -3,7 +3,8 @@ namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors tuples sbufs inference.dataflow hashtables.private sequences.private math tuples.private growable namespaces.private alien.remote-control assocs words -generator command-line vocabs io prettyprint libc ; +generator command-line vocabs io prettyprint libc definitions ; +IN: bootstrap.compiler "cpu." cpu append require @@ -12,6 +13,8 @@ generator command-line vocabs io prettyprint libc ; 0 profiler-prologue set-global ] when +: compile* [ compiled? not ] subset compile ; + ! Compile a set of words ahead of our general ! compile-all. This set of words was determined ! semi-empirically using the profiler. It improves @@ -36,22 +39,24 @@ generator command-line vocabs io prettyprint libc ; find-pair-next namestack* bitand bitor bitxor bitnot -} compile +} compile* { + 1+ 1- 2/ < <= > >= shift min -} compile +} compile* { new nth push pop peek hashcode* = get set -} compile +} compile* { . lines -} compile +} compile* { malloc free memcpy -} compile +} compile* [ compile ] recompile-hook set-global + +FORGET: compile* diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index ab491c72b0..2e4ad9193a 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -46,15 +46,13 @@ IN: bootstrap.stage2 init-io init-stdio - "compile-errors" "generator" lookup [ - f swap set-global - ] when* - run-bootstrap-init f error set-global f error-continuation set-global + all-words [ compiled? not ] subset recompile-hook get call + "deploy-vocab" get [ "tools.deploy.shaker" run ] [ diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 4f3e07daf1..e078a4eee9 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -92,7 +92,7 @@ HELP: compile-quot { $description "Creates a new uninterned word having the given quotation as its definition, and compiles it. The returned word can be passed to " { $link execute } "." } { $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; -HELP: compile-1 +HELP: compile-call { $values { "quot" "a quotation" } } { $description "Compiles and runs a quotation." } { $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 35f8283c42..fb3ec90a74 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -33,7 +33,7 @@ SYMBOL: compiler-hook dup compile-begins dup word-dataflow optimize >r over dup r> generate ] [ - print-error f + print-error f over compiled get set-at f ] recover 2dup ripple-up save-effect ; diff --git a/core/compiler/test/curry.factor b/core/compiler/test/curry.factor index 0e840154ca..77ac01e101 100755 --- a/core/compiler/test/curry.factor +++ b/core/compiler/test/curry.factor @@ -2,43 +2,43 @@ USING: tools.test compiler quotations math kernel sequences assocs namespaces ; IN: temporary -[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-1 ] unit-test -[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-1 ] unit-test -[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-1 ] unit-test -[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-1 ] unit-test -[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-1 ] unit-test -[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-1 ] unit-test -[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-1 ] unit-test +[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test +[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test +[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-call ] unit-test +[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-call ] unit-test +[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-call ] unit-test +[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test +[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test -[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-1 ] unit-test +[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-call ] unit-test -[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-1 >quotation ] unit-test -[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-1 >quotation ] unit-test -[ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-1 >quotation ] unit-test -[ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-1 >quotation ] unit-test -[ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-1 >quotation ] unit-test +[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test +[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test +[ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-call >quotation ] unit-test +[ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-call >quotation ] unit-test +[ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-call >quotation ] unit-test [ [ 6 2 + ] ] [ 2 5 [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry ] - compile-1 >quotation + compile-call >quotation ] unit-test [ 8 ] [ 2 5 [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry call ] - compile-1 + compile-call ] unit-test : foobar ( quot -- ) dup slip swap [ foobar ] [ drop ] if ; inline -[ ] [ [ [ f ] foobar ] compile-1 ] unit-test +[ ] [ [ [ f ] foobar ] compile-call ] unit-test -[ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-1 ] unit-test -[ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-1 ] unit-test +[ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-call ] unit-test +[ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-call ] unit-test : funky-assoc>map [ @@ -46,16 +46,16 @@ IN: temporary ] { } make ; inline [ t ] [ - global [ [ drop , ] funky-assoc>map ] compile-1 + global [ [ drop , ] funky-assoc>map ] compile-call global keys = ] unit-test -[ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test +[ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-call ] unit-test -[ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test +[ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-call ] unit-test -[ 3 ] [ t [ 3 [ ] curry [ 4 ] if ] compile-1 ] unit-test +[ 3 ] [ t [ 3 [ ] curry [ 4 ] if ] compile-call ] unit-test -[ 4 ] [ f [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test +[ 4 ] [ f [ 3 [ ] curry 4 [ ] curry if ] compile-call ] unit-test -[ 4 ] [ f [ [ 3 ] 4 [ ] curry if ] compile-1 ] unit-test +[ 4 ] [ f [ [ 3 ] 4 [ ] curry if ] compile-call ] unit-test diff --git a/core/compiler/test/float.factor b/core/compiler/test/float.factor old mode 100644 new mode 100755 index 404626dd36..10d3baea9b --- a/core/compiler/test/float.factor +++ b/core/compiler/test/float.factor @@ -2,84 +2,84 @@ IN: temporary USING: compiler kernel kernel.private memory math math.private tools.test math.floats.private ; -[ 5.0 ] [ [ 5.0 ] compile-1 data-gc data-gc data-gc ] unit-test -[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test +[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test +[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test -[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test +[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test -[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-1 ] unit-test +[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test -[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-1 ] unit-test +[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test -[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test -[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test -[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-1 ] unit-test -[ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-1 ] unit-test +[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test +[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test +[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-call ] unit-test +[ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-call ] unit-test -[ -1.0 ] [ 1.0 [ 2.0 float- ] compile-1 ] unit-test -[ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-1 ] unit-test -[ -1.0 ] [ 1.0 2.0 [ float- ] compile-1 ] unit-test -[ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-1 ] unit-test +[ -1.0 ] [ 1.0 [ 2.0 float- ] compile-call ] unit-test +[ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-call ] unit-test +[ -1.0 ] [ 1.0 2.0 [ float- ] compile-call ] unit-test +[ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-call ] unit-test -[ 6.0 ] [ 3.0 [ 2.0 float* ] compile-1 ] unit-test -[ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-1 ] unit-test -[ 6.0 ] [ 3.0 2.0 [ float* ] compile-1 ] unit-test -[ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-1 ] unit-test +[ 6.0 ] [ 3.0 [ 2.0 float* ] compile-call ] unit-test +[ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-call ] unit-test +[ 6.0 ] [ 3.0 2.0 [ float* ] compile-call ] unit-test +[ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-call ] unit-test -[ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-1 ] unit-test -[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test -[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test -[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-1 ] unit-test +[ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-call ] unit-test +[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-call ] unit-test +[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-call ] unit-test +[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-call ] unit-test -[ t ] [ 1.0 2.0 [ float< ] compile-1 ] unit-test -[ t ] [ 1.0 [ 2.0 float< ] compile-1 ] unit-test -[ f ] [ 1.0 [ 2.0 swap float< ] compile-1 ] unit-test -[ f ] [ 1.0 1.0 [ float< ] compile-1 ] unit-test -[ f ] [ 1.0 [ 1.0 float< ] compile-1 ] unit-test -[ f ] [ 1.0 [ 1.0 swap float< ] compile-1 ] unit-test -[ f ] [ 3.0 1.0 [ float< ] compile-1 ] unit-test -[ f ] [ 3.0 [ 1.0 float< ] compile-1 ] unit-test -[ t ] [ 3.0 [ 1.0 swap float< ] compile-1 ] unit-test +[ t ] [ 1.0 2.0 [ float< ] compile-call ] unit-test +[ t ] [ 1.0 [ 2.0 float< ] compile-call ] unit-test +[ f ] [ 1.0 [ 2.0 swap float< ] compile-call ] unit-test +[ f ] [ 1.0 1.0 [ float< ] compile-call ] unit-test +[ f ] [ 1.0 [ 1.0 float< ] compile-call ] unit-test +[ f ] [ 1.0 [ 1.0 swap float< ] compile-call ] unit-test +[ f ] [ 3.0 1.0 [ float< ] compile-call ] unit-test +[ f ] [ 3.0 [ 1.0 float< ] compile-call ] unit-test +[ t ] [ 3.0 [ 1.0 swap float< ] compile-call ] unit-test -[ t ] [ 1.0 2.0 [ float<= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 2.0 float<= ] compile-1 ] unit-test -[ f ] [ 1.0 [ 2.0 swap float<= ] compile-1 ] unit-test -[ t ] [ 1.0 1.0 [ float<= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 1.0 float<= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 1.0 swap float<= ] compile-1 ] unit-test -[ f ] [ 3.0 1.0 [ float<= ] compile-1 ] unit-test -[ f ] [ 3.0 [ 1.0 float<= ] compile-1 ] unit-test -[ t ] [ 3.0 [ 1.0 swap float<= ] compile-1 ] unit-test +[ t ] [ 1.0 2.0 [ float<= ] compile-call ] unit-test +[ t ] [ 1.0 [ 2.0 float<= ] compile-call ] unit-test +[ f ] [ 1.0 [ 2.0 swap float<= ] compile-call ] unit-test +[ t ] [ 1.0 1.0 [ float<= ] compile-call ] unit-test +[ t ] [ 1.0 [ 1.0 float<= ] compile-call ] unit-test +[ t ] [ 1.0 [ 1.0 swap float<= ] compile-call ] unit-test +[ f ] [ 3.0 1.0 [ float<= ] compile-call ] unit-test +[ f ] [ 3.0 [ 1.0 float<= ] compile-call ] unit-test +[ t ] [ 3.0 [ 1.0 swap float<= ] compile-call ] unit-test -[ f ] [ 1.0 2.0 [ float> ] compile-1 ] unit-test -[ f ] [ 1.0 [ 2.0 float> ] compile-1 ] unit-test -[ t ] [ 1.0 [ 2.0 swap float> ] compile-1 ] unit-test -[ f ] [ 1.0 1.0 [ float> ] compile-1 ] unit-test -[ f ] [ 1.0 [ 1.0 float> ] compile-1 ] unit-test -[ f ] [ 1.0 [ 1.0 swap float> ] compile-1 ] unit-test -[ t ] [ 3.0 1.0 [ float> ] compile-1 ] unit-test -[ t ] [ 3.0 [ 1.0 float> ] compile-1 ] unit-test -[ f ] [ 3.0 [ 1.0 swap float> ] compile-1 ] unit-test +[ f ] [ 1.0 2.0 [ float> ] compile-call ] unit-test +[ f ] [ 1.0 [ 2.0 float> ] compile-call ] unit-test +[ t ] [ 1.0 [ 2.0 swap float> ] compile-call ] unit-test +[ f ] [ 1.0 1.0 [ float> ] compile-call ] unit-test +[ f ] [ 1.0 [ 1.0 float> ] compile-call ] unit-test +[ f ] [ 1.0 [ 1.0 swap float> ] compile-call ] unit-test +[ t ] [ 3.0 1.0 [ float> ] compile-call ] unit-test +[ t ] [ 3.0 [ 1.0 float> ] compile-call ] unit-test +[ f ] [ 3.0 [ 1.0 swap float> ] compile-call ] unit-test -[ f ] [ 1.0 2.0 [ float>= ] compile-1 ] unit-test -[ f ] [ 1.0 [ 2.0 float>= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 2.0 swap float>= ] compile-1 ] unit-test -[ t ] [ 1.0 1.0 [ float>= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 1.0 float>= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 1.0 swap float>= ] compile-1 ] unit-test -[ t ] [ 3.0 1.0 [ float>= ] compile-1 ] unit-test -[ t ] [ 3.0 [ 1.0 float>= ] compile-1 ] unit-test -[ f ] [ 3.0 [ 1.0 swap float>= ] compile-1 ] unit-test +[ f ] [ 1.0 2.0 [ float>= ] compile-call ] unit-test +[ f ] [ 1.0 [ 2.0 float>= ] compile-call ] unit-test +[ t ] [ 1.0 [ 2.0 swap float>= ] compile-call ] unit-test +[ t ] [ 1.0 1.0 [ float>= ] compile-call ] unit-test +[ t ] [ 1.0 [ 1.0 float>= ] compile-call ] unit-test +[ t ] [ 1.0 [ 1.0 swap float>= ] compile-call ] unit-test +[ t ] [ 3.0 1.0 [ float>= ] compile-call ] unit-test +[ t ] [ 3.0 [ 1.0 float>= ] compile-call ] unit-test +[ f ] [ 3.0 [ 1.0 swap float>= ] compile-call ] unit-test -[ f ] [ 1.0 2.0 [ float= ] compile-1 ] unit-test -[ t ] [ 1.0 1.0 [ float= ] compile-1 ] unit-test -[ f ] [ 1.0 [ 2.0 float= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 1.0 float= ] compile-1 ] unit-test -[ f ] [ 1.0 [ 2.0 swap float= ] compile-1 ] unit-test -[ t ] [ 1.0 [ 1.0 swap float= ] compile-1 ] unit-test +[ f ] [ 1.0 2.0 [ float= ] compile-call ] unit-test +[ t ] [ 1.0 1.0 [ float= ] compile-call ] unit-test +[ f ] [ 1.0 [ 2.0 float= ] compile-call ] unit-test +[ t ] [ 1.0 [ 1.0 float= ] compile-call ] unit-test +[ f ] [ 1.0 [ 2.0 swap float= ] compile-call ] unit-test +[ t ] [ 1.0 [ 1.0 swap float= ] compile-call ] unit-test -[ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test -[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test -[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test +[ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test +[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test +[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test -[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-1 ] unit-test +[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test diff --git a/core/compiler/test/ifte.factor b/core/compiler/test/ifte.factor index aec971245c..802cad5032 100755 --- a/core/compiler/test/ifte.factor +++ b/core/compiler/test/ifte.factor @@ -98,7 +98,7 @@ DEFER: countdown-b { [ dup 2 mod 0 = ] [ drop "even" ] } { [ dup 2 mod 1 = ] [ drop "odd" ] } } cond - ] compile-1 + ] compile-call ] unit-test [ "odd" ] [ @@ -107,7 +107,7 @@ DEFER: countdown-b { [ dup 2 mod 0 = ] [ drop "even" ] } { [ dup 2 mod 1 = ] [ drop "odd" ] } } cond - ] compile-1 + ] compile-call ] unit-test [ "neither" ] [ @@ -118,7 +118,7 @@ DEFER: countdown-b { [ dup alien? ] [ drop "alien" ] } { [ t ] [ drop "neither" ] } } cond - ] compile-1 + ] compile-call ] unit-test [ 3 ] [ @@ -127,5 +127,5 @@ DEFER: countdown-b { [ dup fixnum? ] [ ] } { [ t ] [ drop t ] } } cond - ] compile-1 + ] compile-call ] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index a907c4c152..f383e83a4b 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -7,258 +7,257 @@ sbufs.private strings.private slots.private alien alien.c-types alien.syntax namespaces libc combinators.private ; ! Make sure that intrinsic ops compile to correct code. -[ ] [ 1 [ drop ] compile-1 ] unit-test -[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test -[ ] [ 1 2 3 [ 3drop ] compile-1 ] unit-test -[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test -[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-1 ] unit-test -[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-1 ] unit-test -[ 2 3 1 ] [ 1 2 3 [ rot ] compile-1 ] unit-test -[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-1 ] unit-test -[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test -[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-1 ] unit-test -[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test -[ 3 ] [ 1 2 3 [ 2nip ] compile-1 ] unit-test -[ 2 1 2 ] [ 1 2 [ tuck ] compile-1 ] unit-test -[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test -[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test -[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test +[ ] [ 1 [ drop ] compile-call ] unit-test +[ ] [ 1 2 [ 2drop ] compile-call ] unit-test +[ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test +[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test +[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test +[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test +[ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test +[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test +[ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test +[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test +[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test +[ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test +[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test +[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test +[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test +[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test -[ 1 ] [ { 1 2 } [ 2 slot ] compile-1 ] unit-test -[ 1 ] [ [ { 1 2 } 2 slot ] compile-1 ] unit-test -[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-1 first ] unit-test -[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-1 first ] unit-test -[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-1 first ] unit-test -[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-1 second ] unit-test -[ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test -[ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test +[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test +[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test +[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test +[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test +[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test +[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test +[ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test +[ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-call second ] unit-test ! Write barrier hits on the wrong value were causing segfaults -[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test +[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test -[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-1 ] unit-test -[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-1 ] unit-test -[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-1 ] unit-test +[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test +[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test +[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test -[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test -[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test -[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test +[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test -[ ] [ [ 0 getenv ] compile-1 drop ] unit-test -[ ] [ 1 getenv [ 1 setenv ] compile-1 ] unit-test +[ ] [ [ 0 getenv ] compile-call drop ] unit-test +[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test -[ ] [ 1 [ drop ] compile-1 ] unit-test -[ ] [ [ 1 drop ] compile-1 ] unit-test -[ ] [ [ 1 2 2drop ] compile-1 ] unit-test -[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test -[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test -[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test -[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test -[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test -[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test -[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test -[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test -[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test -[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test -[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test -[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test -[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test -[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test -[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test -[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test -[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test -[ 2 ] [ [ 1 2 nip ] compile-1 ] unit-test -[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test -[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test +[ ] [ 1 [ drop ] compile-call ] unit-test +[ ] [ [ 1 drop ] compile-call ] unit-test +[ ] [ [ 1 2 2drop ] compile-call ] unit-test +[ ] [ 1 [ 2 2drop ] compile-call ] unit-test +[ ] [ 1 2 [ 2drop ] compile-call ] unit-test +[ 2 1 ] [ [ 1 2 swap ] compile-call ] unit-test +[ 2 1 ] [ 1 [ 2 swap ] compile-call ] unit-test +[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test +[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test +[ 1 1 ] [ [ 1 dup ] compile-call ] unit-test +[ 1 2 1 ] [ [ 1 2 over ] compile-call ] unit-test +[ 1 2 1 ] [ 1 [ 2 over ] compile-call ] unit-test +[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test +[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-call ] unit-test +[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-call ] unit-test +[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-call ] unit-test +[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test +[ 1 1 2 ] [ [ 1 2 dupd ] compile-call ] unit-test +[ 1 1 2 ] [ 1 [ 2 dupd ] compile-call ] unit-test +[ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test +[ 2 ] [ [ 1 2 nip ] compile-call ] unit-test +[ 2 ] [ 1 [ 2 nip ] compile-call ] unit-test +[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test -[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-1 ] unit-test +[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-call ] unit-test -[ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test -[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test -[ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test +[ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test +[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test +[ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test -[ 15 ] [ 12 7 [ fixnum-bitor ] compile-1 ] unit-test -[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-1 ] unit-test -[ 15 ] [ [ 12 7 fixnum-bitor ] compile-1 ] unit-test +[ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test +[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test +[ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test -[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-1 ] unit-test -[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-1 ] unit-test -[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-1 ] unit-test +[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test +[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test +[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test -[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test +[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test -[ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test +[ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test -[ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test +[ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test -[ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test +[ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test -[ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test +[ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test -[ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test +[ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test -[ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test +[ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test -[ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test +[ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test -[ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test -[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test -[ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test +[ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-call ] unit-test +[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] unit-test +[ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-call ] unit-test -[ -1 ] [ 0 [ fixnum-bitnot ] compile-1 ] unit-test -[ -1 ] [ [ 0 fixnum-bitnot ] compile-1 ] unit-test +[ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] unit-test +[ -1 ] [ [ 0 fixnum-bitnot ] compile-call ] unit-test -[ 3 ] [ 13 10 [ fixnum-mod ] compile-1 ] unit-test -[ 3 ] [ 13 [ 10 fixnum-mod ] compile-1 ] unit-test -[ 3 ] [ [ 13 10 fixnum-mod ] compile-1 ] unit-test -[ -3 ] [ -13 10 [ fixnum-mod ] compile-1 ] unit-test -[ -3 ] [ -13 [ 10 fixnum-mod ] compile-1 ] unit-test -[ -3 ] [ [ -13 10 fixnum-mod ] compile-1 ] unit-test +[ 3 ] [ 13 10 [ fixnum-mod ] compile-call ] unit-test +[ 3 ] [ 13 [ 10 fixnum-mod ] compile-call ] unit-test +[ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test +[ -3 ] [ -13 10 [ fixnum-mod ] compile-call ] unit-test +[ -3 ] [ -13 [ 10 fixnum-mod ] compile-call ] unit-test +[ -3 ] [ [ -13 10 fixnum-mod ] compile-call ] unit-test -[ 2 ] [ 4 2 [ fixnum/i ] compile-1 ] unit-test -[ 2 ] [ 4 [ 2 fixnum/i ] compile-1 ] unit-test -[ -2 ] [ 4 [ -2 fixnum/i ] compile-1 ] unit-test -[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-1 ] unit-test +[ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test +[ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test +[ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test +[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test -[ 4 ] [ 1 3 [ fixnum+ ] compile-1 ] unit-test -[ 4 ] [ 1 [ 3 fixnum+ ] compile-1 ] unit-test -[ 4 ] [ [ 1 3 fixnum+ ] compile-1 ] unit-test +[ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test +[ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test +[ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test -[ 4 ] [ 1 3 [ fixnum+fast ] compile-1 ] unit-test -[ 4 ] [ 1 [ 3 fixnum+fast ] compile-1 ] unit-test -[ 4 ] [ [ 1 3 fixnum+fast ] compile-1 ] unit-test +[ 4 ] [ 1 3 [ fixnum+fast ] compile-call ] unit-test +[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test +[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test -[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-1 ] unit-test +[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test -[ 6 ] [ 2 3 [ fixnum*fast ] compile-1 ] unit-test -[ 6 ] [ 2 [ 3 fixnum*fast ] compile-1 ] unit-test -[ 6 ] [ [ 2 3 fixnum*fast ] compile-1 ] unit-test -[ -6 ] [ 2 -3 [ fixnum*fast ] compile-1 ] unit-test -[ -6 ] [ 2 [ -3 fixnum*fast ] compile-1 ] unit-test -[ -6 ] [ [ 2 -3 fixnum*fast ] compile-1 ] unit-test +[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test +[ 6 ] [ 2 [ 3 fixnum*fast ] compile-call ] unit-test +[ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test +[ -6 ] [ 2 -3 [ fixnum*fast ] compile-call ] unit-test +[ -6 ] [ 2 [ -3 fixnum*fast ] compile-call ] unit-test +[ -6 ] [ [ 2 -3 fixnum*fast ] compile-call ] unit-test -[ 6 ] [ 2 3 [ fixnum* ] compile-1 ] unit-test -[ 6 ] [ 2 [ 3 fixnum* ] compile-1 ] unit-test -[ 6 ] [ [ 2 3 fixnum* ] compile-1 ] unit-test -[ -6 ] [ 2 -3 [ fixnum* ] compile-1 ] unit-test -[ -6 ] [ 2 [ -3 fixnum* ] compile-1 ] unit-test -[ -6 ] [ [ 2 -3 fixnum* ] compile-1 ] unit-test +[ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test +[ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test +[ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test +[ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test +[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test +[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test -[ t ] [ 3 type 3 [ type ] compile-1 eq? ] unit-test -[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-1 eq? ] unit-test -[ t ] [ "hey" type "hey" [ type ] compile-1 eq? ] unit-test -[ t ] [ f type f [ type ] compile-1 eq? ] unit-test +[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test +[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test +[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test +[ t ] [ f type f [ type ] compile-call eq? ] unit-test -[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test -[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test -[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-1 ] unit-test -[ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-1 ] unit-test +[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test +[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test +[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test +[ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test -[ 8 ] [ 1 3 [ fixnum-shift ] compile-1 ] unit-test -[ 8 ] [ 1 [ 3 fixnum-shift ] compile-1 ] unit-test -[ 8 ] [ [ 1 3 fixnum-shift ] compile-1 ] unit-test -[ -8 ] [ -1 3 [ fixnum-shift ] compile-1 ] unit-test -[ -8 ] [ -1 [ 3 fixnum-shift ] compile-1 ] unit-test -[ -8 ] [ [ -1 3 fixnum-shift ] compile-1 ] unit-test +[ 8 ] [ 1 3 [ fixnum-shift ] compile-call ] unit-test +[ 8 ] [ 1 [ 3 fixnum-shift ] compile-call ] unit-test +[ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test +[ -8 ] [ -1 3 [ fixnum-shift ] compile-call ] unit-test +[ -8 ] [ -1 [ 3 fixnum-shift ] compile-call ] unit-test +[ -8 ] [ [ -1 3 fixnum-shift ] compile-call ] unit-test -[ 2 ] [ 8 -2 [ fixnum-shift ] compile-1 ] unit-test -[ 2 ] [ 8 [ -2 fixnum-shift ] compile-1 ] unit-test +[ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] unit-test +[ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] unit-test -[ 0 ] [ [ 123 -64 fixnum-shift ] compile-1 ] unit-test -[ 0 ] [ 123 -64 [ fixnum-shift ] compile-1 ] unit-test -[ -1 ] [ [ -123 -64 fixnum-shift ] compile-1 ] unit-test -[ -1 ] [ -123 -64 [ fixnum-shift ] compile-1 ] unit-test +[ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test +[ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test +[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test +[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test -[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-1 ] unit-test -[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-1 ] unit-test +[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test +[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test -[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-1 1 28 fixnum-shift = ] unit-test -[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] unit-test +[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test +[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test -[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-1 ] unit-test -[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-1 ] unit-test -[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test -[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-1 ] unit-test -[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-1 ] unit-test -[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test +[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test +[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test +[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test +[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test +[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test +[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test -[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-1 1 40 shift = ] unit-test -[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-1 1 40 shift neg = ] unit-test -[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-1 1 40 shift = ] unit-test -[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-1 ] unit-test +[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test +[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test +[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test +[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test +[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test -[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test +[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test -[ t ] [ f [ f eq? ] compile-1 ] unit-test +[ t ] [ f [ f eq? ] compile-call ] unit-test ! regression -[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-1 2nip ] unit-test +[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test ! regression [ 3 ] [ 100001 f 3 100000 pick set-nth - [ 100000 swap array-nth ] compile-1 + [ 100000 swap array-nth ] compile-call ] unit-test ! 64-bit overflow cell 8 = [ - [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-1 1 60 fixnum-shift = ] unit-test - [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] unit-test + [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test + [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test - [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-1 1 80 shift = ] unit-test - [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-1 1 80 shift neg = ] unit-test - [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test - [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test - [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test + [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test + [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test + [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test + [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test + [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test - [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-1 ] unit-test - [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-1 ] unit-test - [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test - [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-1 ] unit-test - [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-1 ] unit-test - [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test + [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test + [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test + [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test + [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test + [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test + [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test - [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test + [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test - [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test + [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test - [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-1 ] unit-test + [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test ] when ! Some randomized tests : compiled-fixnum* fixnum* ; -\ compiled-fixnum* compile : test-fixnum* (random) >fixnum (random) >fixnum @@ -269,7 +268,6 @@ cell 8 = [ [ ] [ 10000 [ test-fixnum* ] times ] unit-test : compiled-fixnum>bignum fixnum>bignum ; -\ compiled-fixnum>bignum compile : test-fixnum>bignum (random) >fixnum @@ -279,7 +277,6 @@ cell 8 = [ [ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test : compiled-bignum>fixnum bignum>fixnum ; -\ compiled-bignum>fixnum compile : test-bignum>fixnum 5 random [ drop (random) ] map product >bignum @@ -292,84 +289,84 @@ cell 8 = [ [ t ] [ most-positive-fixnum 100 - >fixnum 200 - [ [ fixnum+ ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep - [ fixnum+ >fixnum ] compile-1 + [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep + [ fixnum+ >fixnum ] compile-call = ] unit-test [ t ] [ most-negative-fixnum 100 + >fixnum -200 - [ [ fixnum+ ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep - [ fixnum+ >fixnum ] compile-1 + [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep + [ fixnum+ >fixnum ] compile-call = ] unit-test [ t ] [ most-negative-fixnum 100 + >fixnum 200 - [ [ fixnum- ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep - [ fixnum- >fixnum ] compile-1 + [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep + [ fixnum- >fixnum ] compile-call = ] unit-test ! Test inline allocators [ { 1 1 1 } ] [ - [ 3 1 ] compile-1 + [ 3 1 ] compile-call ] unit-test [ B{ 0 0 0 } ] [ - [ 3 ] compile-1 + [ 3 ] compile-call ] unit-test [ 500 ] [ - [ 500 length ] compile-1 + [ 500 length ] compile-call ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-1 dup real swap imaginary + 1 2 [ ] compile-call dup real swap imaginary ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-1 dup numerator swap denominator + 1 2 [ ] compile-call dup numerator swap denominator ] unit-test -[ \ + ] [ \ + [ ] compile-1 ] unit-test +[ \ + ] [ \ + [ ] compile-call ] unit-test [ H{ } ] [ - 100 [ (hashtable) ] compile-1 [ reset-hash ] keep + 100 [ (hashtable) ] compile-call [ reset-hash ] keep ] unit-test [ B{ 0 0 0 0 0 } ] [ - [ 5 ] compile-1 + [ 5 ] compile-call ] unit-test [ V{ 1 2 } ] [ - { 1 2 3 } 2 [ array>vector ] compile-1 + { 1 2 3 } 2 [ array>vector ] compile-call ] unit-test [ SBUF" hello" ] [ - "hello world" 5 [ string>sbuf ] compile-1 + "hello world" 5 [ string>sbuf ] compile-call ] unit-test [ [ 3 + ] ] [ - 3 [ + ] [ curry ] compile-1 + 3 [ + ] [ curry ] compile-call ] unit-test ! Alien intrinsics -[ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test +[ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-call ] unit-test +[ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-call ] unit-test +[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test +[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test [ t ] [ "b" get >boolean ] unit-test "b" get [ - [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test - [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test - [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test - [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test + [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test + [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test + [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ ] [ "b" get free ] unit-test ] when @@ -377,61 +374,61 @@ cell 8 = [ [ ] [ "hello world" malloc-char-string "s" set ] unit-test "s" get [ - [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test - [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test + [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test + [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test [ ] [ "s" get free ] unit-test ] when -[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare ] compile-1 *void* ] unit-test -[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare ] compile-1 *void* ] unit-test -[ f ] [ f [ { POSTPONE: f } declare ] compile-1 *void* ] unit-test +[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare ] compile-call *void* ] unit-test +[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare ] compile-call *void* ] unit-test +[ f ] [ f [ { POSTPONE: f } declare ] compile-call *void* ] unit-test -[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-1 ] unit-test +[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test +[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test : xword-def word-def [ { fixnum } declare ] swap append ; -[ -100 ] [ -100 [ { byte-array } declare *char ] compile-1 ] unit-test -[ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-1 ] unit-test +[ -100 ] [ -100 [ { byte-array } declare *char ] compile-call ] unit-test +[ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test -[ -100 ] [ -100 \ xword-def compile-1 *char ] unit-test -[ 156 ] [ -100 \ xword-def compile-1 *uchar ] unit-test +[ -100 ] [ -100 \ xword-def compile-call *char ] unit-test +[ 156 ] [ -100 \ xword-def compile-call *uchar ] unit-test -[ -1000 ] [ -1000 [ { byte-array } declare *short ] compile-1 ] unit-test -[ 64536 ] [ -1000 [ { byte-array } declare *ushort ] compile-1 ] unit-test +[ -1000 ] [ -1000 [ { byte-array } declare *short ] compile-call ] unit-test +[ 64536 ] [ -1000 [ { byte-array } declare *ushort ] compile-call ] unit-test -[ -1000 ] [ -1000 \ xword-def compile-1 *short ] unit-test -[ 64536 ] [ -1000 \ xword-def compile-1 *ushort ] unit-test +[ -1000 ] [ -1000 \ xword-def compile-call *short ] unit-test +[ 64536 ] [ -1000 \ xword-def compile-call *ushort ] unit-test -[ -100000 ] [ -100000 [ { byte-array } declare *int ] compile-1 ] unit-test -[ 4294867296 ] [ -100000 [ { byte-array } declare *uint ] compile-1 ] unit-test +[ -100000 ] [ -100000 [ { byte-array } declare *int ] compile-call ] unit-test +[ 4294867296 ] [ -100000 [ { byte-array } declare *uint ] compile-call ] unit-test -[ -100000 ] [ -100000 \ xword-def compile-1 *int ] unit-test -[ 4294867296 ] [ -100000 \ xword-def compile-1 *uint ] unit-test +[ -100000 ] [ -100000 \ xword-def compile-call *int ] unit-test +[ 4294867296 ] [ -100000 \ xword-def compile-call *uint ] unit-test [ t ] [ pi pi *double = ] unit-test -[ t ] [ pi [ { byte-array } declare *double ] compile-1 pi = ] unit-test +[ t ] [ pi [ { byte-array } declare *double ] compile-call pi = ] unit-test ! Silly -[ t ] [ pi 4 [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - -0.001 0.001 between? ] unit-test -[ t ] [ pi [ { byte-array } declare *float ] compile-1 pi - -0.001 0.001 between? ] unit-test +[ t ] [ pi 4 [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test +[ t ] [ pi [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test -[ t ] [ pi 8 [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test +[ t ] [ pi 8 [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test [ 4 ] [ 2 B{ 1 2 3 4 5 6 } [ { alien } declare 1 alien-unsigned-1 - ] compile-1 + ] compile-call ] unit-test [ - B{ 0 0 0 0 } [ { byte-array } declare ] compile-1 + B{ 0 0 0 0 } [ { byte-array } declare ] compile-call ] unit-test-fails [ - B{ 0 0 0 0 } [ { c-ptr } declare ] compile-1 + B{ 0 0 0 0 } [ { c-ptr } declare ] compile-call ] unit-test-fails [ @@ -441,5 +438,5 @@ cell 8 = [ [ { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch ] keep 2 fixnum+fast - ] compile-1 + ] compile-call ] unit-test diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 7a9144b97e..d4ed5686f7 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -50,7 +50,7 @@ FORGET: xyz GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ ] [ \ xyz compile ] unit-test +[ t ] [ \ xyz compiled? ] unit-test ! Test predicate inlining : pred-test-1 @@ -135,7 +135,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) : breakage "hi" void-generic ; -[ ] [ \ breakage compile ] unit-test +[ t ] [ \ breakage compiled? ] unit-test [ breakage ] unit-test-fails ! regression @@ -156,7 +156,7 @@ GENERIC: void-generic ( obj -- * ) ! another regression : constant-branch-fold-0 "hey" ; foldable : constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-1 ] unit-test +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test ! another regression : foo f ; @@ -184,71 +184,71 @@ M: slice foozul ; : constant-fold-3 4 ; foldable [ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-1 + [ constant-fold-2 constant-fold-3 4 = ] compile-call ] unit-test : constant-fold-4 f ; foldable : constant-fold-5 f ; foldable [ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-1 + [ constant-fold-4 constant-fold-5 or ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 + ] compile-1 ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-1 ] unit-test +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 - ] compile-1 ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-1 ] unit-test -[ 0 ] [ 5 [ dup - ] compile-1 ] unit-test +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 * ] compile-1 ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-1 ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-1 ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-1 ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-1 ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-1 ] unit-test +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 bitand ] compile-1 ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-1 ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-1 ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-1 ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-1 ] unit-test +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 bitor ] compile-1 ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-1 ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-1 ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-1 ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-1 ] unit-test +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 bitxor ] compile-1 ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-1 ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-1 ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-1 ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-1 ] unit-test +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap shift ] compile-1 ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-1 ] unit-test +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test -[ f ] [ 5 [ dup < ] compile-1 ] unit-test -[ t ] [ 5 [ dup <= ] compile-1 ] unit-test -[ f ] [ 5 [ dup > ] compile-1 ] unit-test -[ t ] [ 5 [ dup >= ] compile-1 ] unit-test +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test -[ t ] [ 5 [ dup eq? ] compile-1 ] unit-test -[ t ] [ 5 [ dup = ] compile-1 ] unit-test -[ t ] [ 5 [ dup number= ] compile-1 ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test GENERIC: detect-number ( obj -- obj ) M: number detect-number ; -[ 10 f [ 0 + detect-number ] compile-1 ] unit-test-fails +[ 10 f [ 0 + detect-number ] compile-call ] unit-test-fails ! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-1 ] unit-test +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test ! Regression USE: sorting @@ -265,7 +265,7 @@ USE: sorting.private [ 10 ] [ 10 20 >vector - [ [ - ] swap old-binsearch ] compile-1 2nip + [ [ - ] swap old-binsearch ] compile-call 2nip ] unit-test ! Regression @@ -275,5 +275,5 @@ TUPLE: silly-tuple a b ; T{ silly-tuple f 1 2 } [ { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-1 + ] compile-call ] unit-test diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor index 73463ec99c..59ee3c3d88 100755 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -10,7 +10,6 @@ words splitting ; : foo 3 throw 7 ; : bar foo 4 ; : baz bar 5 ; -\ baz compile [ 3 ] [ [ baz ] catch ] unit-test [ t ] [ symbolic-stack-trace @@ -19,7 +18,6 @@ words splitting ; ] unit-test : bleh [ 3 + ] map [ 0 > ] subset ; -\ bleh compile : stack-trace-contains? symbolic-stack-trace memq? ; @@ -34,7 +32,6 @@ words splitting ; ] unit-test : quux [ t [ "hi" throw ] when ] times ; -\ quux compile [ t ] [ [ 10 quux ] catch drop diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor index 15d626a889..46c4225092 100755 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -7,48 +7,48 @@ combinators.private byte-arrays alien layouts ; IN: temporary ! Oops! -[ 5000 ] [ [ 5000 ] compile-1 ] unit-test -[ "hi" ] [ [ "hi" ] compile-1 ] unit-test +[ 5000 ] [ [ 5000 ] compile-call ] unit-test +[ "hi" ] [ [ "hi" ] compile-call ] unit-test -[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-1 ] unit-test +[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test -[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test -[ 0 ] [ 3 [ tag ] compile-1 ] unit-test -[ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test +[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test +[ 0 ] [ 3 [ tag ] compile-call ] unit-test +[ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test -[ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test +[ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test -[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-1 ] unit-test +[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test -[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test +[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test [ { 1 2 3 } { 1 4 3 } 3 3 ] -[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-1 ] +[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ] unit-test [ { 1 2 3 } { 1 4 3 } 8 8 ] -[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ] +[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ] unit-test ! Test literals in either side of a shuffle -[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test +[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test -[ 2 ] [ 1 2 [ swap fixnum/i ] compile-1 ] unit-test +[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test : foo ; [ 5 5 ] -[ 1.2 [ tag [ foo ] keep ] compile-1 ] +[ 1.2 [ tag [ foo ] keep ] compile-call ] unit-test [ 1 2 2 ] -[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-1 ] +[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ] unit-test [ 3 ] [ global [ 3 \ foo set ] bind - \ foo [ global >n get ndrop ] compile-1 + \ foo [ global >n get ndrop ] compile-call ] unit-test : blech drop ; @@ -56,48 +56,48 @@ unit-test [ 3 ] [ global [ 3 \ foo set ] bind - \ foo [ global [ get ] swap blech call ] compile-1 + \ foo [ global [ get ] swap blech call ] compile-call ] unit-test [ 3 ] [ global [ 3 \ foo set ] bind - \ foo [ global [ get ] swap >n call ndrop ] compile-1 + \ foo [ global [ get ] swap >n call ndrop ] compile-call ] unit-test [ 3 ] [ global [ 3 \ foo set ] bind - \ foo [ global [ get ] bind ] compile-1 + \ foo [ global [ get ] bind ] compile-call ] unit-test [ 12 13 ] [ - -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-1 + -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call ] unit-test -[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-1 ] unit-test +[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test [ 12 13 ] [ - -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-1 + -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call ] unit-test [ 2 ] [ - SBUF" " [ 2 slot 2 [ slot ] keep ] compile-1 nip + SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip ] unit-test ! Test slow shuffles [ 3 1 2 3 4 5 6 7 8 9 ] [ 1 2 3 4 5 6 7 8 9 [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ] - compile-1 + compile-call ] unit-test [ 2 2 2 2 2 2 2 2 2 2 1 ] [ 1 2 - [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-1 + [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call ] unit-test -[ ] [ [ 9 [ ] times ] compile-1 ] unit-test +[ ] [ [ 9 [ ] times ] compile-call ] unit-test [ ] [ [ @@ -122,7 +122,7 @@ unit-test [ 2.0 { 2.0 0.0 } ] [ 2.0 1.0 - [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-1 + [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call ] unit-test ! Regression @@ -143,7 +143,7 @@ unit-test [ ] [ H{ { 1 2 } { 3 4 } } dup hash-array - [ 0 swap hellish-bug-2 drop ] compile-1 + [ 0 swap hellish-bug-2 drop ] compile-call ] unit-test ! Regression @@ -160,34 +160,34 @@ TUPLE: my-tuple ; [ 5 ] [ "hi" foox ] unit-test ! Making sure we don't needlessly unbox/rebox -[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-1 ] unit-test +[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test -[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-1 >r eq? r> ] unit-test +[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test -[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-1 nip eq? ] unit-test +[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test [ 1 B{ 1 2 3 4 } ] [ B{ 1 2 3 4 } [ { byte-array } declare [ 0 alien-unsigned-1 ] keep - ] compile-1 + ] compile-call ] unit-test [ 1 t ] [ B{ 1 2 3 4 } [ { c-ptr } declare [ 0 alien-unsigned-1 ] keep type - ] compile-1 byte-array type-number = + ] compile-call byte-array type-number = ] unit-test [ t ] [ B{ 1 2 3 4 } [ { c-ptr } declare 0 alien-cell type - ] compile-1 alien type-number = + ] compile-call alien type-number = ] unit-test [ 2 1 ] [ 2 1 - [ 2dup fixnum< [ >r die r> ] when ] compile-1 + [ 2dup fixnum< [ >r die r> ] when ] compile-call ] unit-test diff --git a/core/compiler/test/tuples.factor b/core/compiler/test/tuples.factor old mode 100644 new mode 100755 index 1a469ea3d9..a23b6739ad --- a/core/compiler/test/tuples.factor +++ b/core/compiler/test/tuples.factor @@ -4,11 +4,11 @@ USING: kernel tools.test compiler ; TUPLE: color red green blue ; [ T{ color f 1 2 3 } ] -[ 1 2 3 [ color construct-boa ] compile-1 ] unit-test +[ 1 2 3 [ color construct-boa ] compile-call ] unit-test [ 1 3 ] [ 1 2 3 color construct-boa - [ { color-red color-blue } get-slots ] compile-1 + [ { color-red color-blue } get-slots ] compile-call ] unit-test [ T{ color f 10 2 20 } ] [ @@ -16,17 +16,17 @@ TUPLE: color red green blue ; 1 2 3 color construct-boa [ [ { set-color-red set-color-blue } set-slots - ] compile-1 + ] compile-call ] keep ] unit-test [ T{ color f f f f } ] -[ [ color construct-empty ] compile-1 ] unit-test +[ [ color construct-empty ] compile-call ] unit-test [ T{ color "a" f "b" f } ] [ "a" "b" [ { set-delegate set-color-green } color construct ] - compile-1 + compile-call ] unit-test -[ T{ color f f f f } ] [ [ { } color construct ] compile-1 ] unit-test +[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 9f3851f8f1..4128559d35 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -15,13 +15,13 @@ SYMBOL: compiled : begin-compiling ( word -- ) f swap compiled get set-at ; -: finish-compiling ( word literals words rel labels code -- ) +: finish-compiling ( word literals words rel labels code profiler-prologue -- ) 6array swap compiled get set-at ; : queue-compile ( word -- ) { - { [ dup compound? not ] [ drop ] } { [ dup compiled get key? ] [ drop ] } + { [ dup compound? not ] [ f swap compiled get set-at ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; From 32641f04e7b96f73a6af88b845e555d9e6bd9b84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Dec 2007 18:10:05 -0500 Subject: [PATCH 20/82] Remove intern-symbol --- core/bootstrap/primitives.factor | 402 ++++++++++++++-------------- core/classes/classes.factor | 2 +- core/definitions/definitions.factor | 3 +- core/parser/parser-tests.factor | 12 +- core/prettyprint/prettyprint.factor | 31 +-- core/words/words-docs.factor | 4 - core/words/words.factor | 6 +- 7 files changed, 229 insertions(+), 231 deletions(-) mode change 100644 => 100755 core/prettyprint/prettyprint.factor diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f1d86deba2..0142d2f9a1 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -79,207 +79,7 @@ H{ } clone source-files set H{ } clone classr create r> define ; - -{ - { "(execute)" "words.private" } - { "(call)" "kernel.private" } - { "uncurry" "kernel.private" } - { "string>sbuf" "sbufs.private" } - { "bignum>fixnum" "math.private" } - { "float>fixnum" "math.private" } - { "fixnum>bignum" "math.private" } - { "float>bignum" "math.private" } - { "fixnum>float" "math.private" } - { "bignum>float" "math.private" } - { "" "math.private" } - { "string>float" "math.private" } - { "float>string" "math.private" } - { "float>bits" "math" } - { "double>bits" "math" } - { "bits>float" "math" } - { "bits>double" "math" } - { "" "math.private" } - { "fixnum+" "math.private" } - { "fixnum+fast" "math.private" } - { "fixnum-" "math.private" } - { "fixnum-fast" "math.private" } - { "fixnum*" "math.private" } - { "fixnum*fast" "math.private" } - { "fixnum/i" "math.private" } - { "fixnum-mod" "math.private" } - { "fixnum/mod" "math.private" } - { "fixnum-bitand" "math.private" } - { "fixnum-bitor" "math.private" } - { "fixnum-bitxor" "math.private" } - { "fixnum-bitnot" "math.private" } - { "fixnum-shift" "math.private" } - { "fixnum<" "math.private" } - { "fixnum<=" "math.private" } - { "fixnum>" "math.private" } - { "fixnum>=" "math.private" } - { "bignum=" "math.private" } - { "bignum+" "math.private" } - { "bignum-" "math.private" } - { "bignum*" "math.private" } - { "bignum/i" "math.private" } - { "bignum-mod" "math.private" } - { "bignum/mod" "math.private" } - { "bignum-bitand" "math.private" } - { "bignum-bitor" "math.private" } - { "bignum-bitxor" "math.private" } - { "bignum-bitnot" "math.private" } - { "bignum-shift" "math.private" } - { "bignum<" "math.private" } - { "bignum<=" "math.private" } - { "bignum>" "math.private" } - { "bignum>=" "math.private" } - { "bignum-bit?" "math.private" } - { "bignum-log2" "math.private" } - { "byte-array>bignum" "math" } - { "float=" "math.private" } - { "float+" "math.private" } - { "float-" "math.private" } - { "float*" "math.private" } - { "float/f" "math.private" } - { "float-mod" "math.private" } - { "float<" "math.private" } - { "float<=" "math.private" } - { "float>" "math.private" } - { "float>=" "math.private" } - { "" "words" } - { "word-xt" "words" } - { "drop" "kernel" } - { "2drop" "kernel" } - { "3drop" "kernel" } - { "dup" "kernel" } - { "2dup" "kernel" } - { "3dup" "kernel" } - { "rot" "kernel" } - { "-rot" "kernel" } - { "dupd" "kernel" } - { "swapd" "kernel" } - { "nip" "kernel" } - { "2nip" "kernel" } - { "tuck" "kernel" } - { "over" "kernel" } - { "pick" "kernel" } - { "swap" "kernel" } - { ">r" "kernel" } - { "r>" "kernel" } - { "eq?" "kernel" } - { "getenv" "kernel.private" } - { "setenv" "kernel.private" } - { "(stat)" "io.files.private" } - { "(directory)" "io.files.private" } - { "data-gc" "memory" } - { "code-gc" "memory" } - { "gc-time" "memory" } - { "save-image" "memory" } - { "save-image-and-exit" "memory" } - { "datastack" "kernel" } - { "retainstack" "kernel" } - { "callstack" "kernel" } - { "set-datastack" "kernel" } - { "set-retainstack" "kernel" } - { "set-callstack" "kernel" } - { "exit" "system" } - { "data-room" "memory" } - { "code-room" "memory" } - { "os-env" "system" } - { "millis" "system" } - { "type" "kernel.private" } - { "tag" "kernel.private" } - { "cwd" "io.files" } - { "cd" "io.files" } - { "modify-code-heap" "words.private" } - { "dlopen" "alien" } - { "dlsym" "alien" } - { "dlclose" "alien" } - { "" "byte-arrays" } - { "" "bit-arrays" } - { "" "alien" } - { "alien-signed-cell" "alien" } - { "set-alien-signed-cell" "alien" } - { "alien-unsigned-cell" "alien" } - { "set-alien-unsigned-cell" "alien" } - { "alien-signed-8" "alien" } - { "set-alien-signed-8" "alien" } - { "alien-unsigned-8" "alien" } - { "set-alien-unsigned-8" "alien" } - { "alien-signed-4" "alien" } - { "set-alien-signed-4" "alien" } - { "alien-unsigned-4" "alien" } - { "set-alien-unsigned-4" "alien" } - { "alien-signed-2" "alien" } - { "set-alien-signed-2" "alien" } - { "alien-unsigned-2" "alien" } - { "set-alien-unsigned-2" "alien" } - { "alien-signed-1" "alien" } - { "set-alien-signed-1" "alien" } - { "alien-unsigned-1" "alien" } - { "set-alien-unsigned-1" "alien" } - { "alien-float" "alien" } - { "set-alien-float" "alien" } - { "alien-double" "alien" } - { "set-alien-double" "alien" } - { "alien-cell" "alien" } - { "set-alien-cell" "alien" } - { "alien>char-string" "alien" } - { "string>char-alien" "alien" } - { "alien>u16-string" "alien" } - { "string>u16-alien" "alien" } - { "(throw)" "kernel.private" } - { "string>memory" "alien" } - { "memory>string" "alien" } - { "alien-address" "alien" } - { "slot" "slots.private" } - { "set-slot" "slots.private" } - { "char-slot" "strings.private" } - { "set-char-slot" "strings.private" } - { "resize-array" "arrays" } - { "resize-string" "strings" } - { "(hashtable)" "hashtables.private" } - { "" "arrays" } - { "begin-scan" "memory" } - { "next-object" "memory" } - { "end-scan" "memory" } - { "size" "memory" } - { "die" "kernel" } - { "fopen" "io.streams.c" } - { "fgetc" "io.streams.c" } - { "fread" "io.streams.c" } - { "fwrite" "io.streams.c" } - { "fflush" "io.streams.c" } - { "fclose" "io.streams.c" } - { "" "kernel" } - { "(clone)" "kernel" } - { "array>vector" "vectors.private" } - { "" "strings" } - { "(>tuple)" "tuples.private" } - { "array>quotation" "quotations.private" } - { "quotation-xt" "quotations" } - { "" "tuples.private" } - { "tuple>array" "tuples" } - { "profiling" "tools.profiler.private" } - { "become" "kernel.private" } - { "(sleep)" "threads.private" } - { "" "float-arrays" } - { "curry" "kernel" } - { "" "tuples.private" } - { "class-hash" "kernel.private" } - { "callstack>array" "kernel" } - { "innermost-frame-quot" "kernel.private" } - { "innermost-frame-scan" "kernel.private" } - { "set-innermost-frame-quot" "kernel.private" } - { "call-clear" "kernel" } - { "strip-compiled-quotations" "quotations" } - { "(os-envs)" "system" } -} -dup length [ >r first2 r> make-primitive ] 2each - -! Okay, now we have primitives fleshed out. Bring up the generic -! word system. +! Builtin classes : builtin-predicate ( class predicate -- ) [ over "type" word-prop dup @@ -607,6 +407,206 @@ builtins get num-tags get tail f union-class define-class "tombstone" "hashtables.private" lookup t 2array >tuple 1quotation define-inline +! Primitive words +: make-primitive ( word vocab n -- ) >r create r> define ; + +{ + { "(execute)" "words.private" } + { "(call)" "kernel.private" } + { "uncurry" "kernel.private" } + { "string>sbuf" "sbufs.private" } + { "bignum>fixnum" "math.private" } + { "float>fixnum" "math.private" } + { "fixnum>bignum" "math.private" } + { "float>bignum" "math.private" } + { "fixnum>float" "math.private" } + { "bignum>float" "math.private" } + { "" "math.private" } + { "string>float" "math.private" } + { "float>string" "math.private" } + { "float>bits" "math" } + { "double>bits" "math" } + { "bits>float" "math" } + { "bits>double" "math" } + { "" "math.private" } + { "fixnum+" "math.private" } + { "fixnum+fast" "math.private" } + { "fixnum-" "math.private" } + { "fixnum-fast" "math.private" } + { "fixnum*" "math.private" } + { "fixnum*fast" "math.private" } + { "fixnum/i" "math.private" } + { "fixnum-mod" "math.private" } + { "fixnum/mod" "math.private" } + { "fixnum-bitand" "math.private" } + { "fixnum-bitor" "math.private" } + { "fixnum-bitxor" "math.private" } + { "fixnum-bitnot" "math.private" } + { "fixnum-shift" "math.private" } + { "fixnum<" "math.private" } + { "fixnum<=" "math.private" } + { "fixnum>" "math.private" } + { "fixnum>=" "math.private" } + { "bignum=" "math.private" } + { "bignum+" "math.private" } + { "bignum-" "math.private" } + { "bignum*" "math.private" } + { "bignum/i" "math.private" } + { "bignum-mod" "math.private" } + { "bignum/mod" "math.private" } + { "bignum-bitand" "math.private" } + { "bignum-bitor" "math.private" } + { "bignum-bitxor" "math.private" } + { "bignum-bitnot" "math.private" } + { "bignum-shift" "math.private" } + { "bignum<" "math.private" } + { "bignum<=" "math.private" } + { "bignum>" "math.private" } + { "bignum>=" "math.private" } + { "bignum-bit?" "math.private" } + { "bignum-log2" "math.private" } + { "byte-array>bignum" "math" } + { "float=" "math.private" } + { "float+" "math.private" } + { "float-" "math.private" } + { "float*" "math.private" } + { "float/f" "math.private" } + { "float-mod" "math.private" } + { "float<" "math.private" } + { "float<=" "math.private" } + { "float>" "math.private" } + { "float>=" "math.private" } + { "" "words" } + { "word-xt" "words" } + { "drop" "kernel" } + { "2drop" "kernel" } + { "3drop" "kernel" } + { "dup" "kernel" } + { "2dup" "kernel" } + { "3dup" "kernel" } + { "rot" "kernel" } + { "-rot" "kernel" } + { "dupd" "kernel" } + { "swapd" "kernel" } + { "nip" "kernel" } + { "2nip" "kernel" } + { "tuck" "kernel" } + { "over" "kernel" } + { "pick" "kernel" } + { "swap" "kernel" } + { ">r" "kernel" } + { "r>" "kernel" } + { "eq?" "kernel" } + { "getenv" "kernel.private" } + { "setenv" "kernel.private" } + { "(stat)" "io.files.private" } + { "(directory)" "io.files.private" } + { "data-gc" "memory" } + { "code-gc" "memory" } + { "gc-time" "memory" } + { "save-image" "memory" } + { "save-image-and-exit" "memory" } + { "datastack" "kernel" } + { "retainstack" "kernel" } + { "callstack" "kernel" } + { "set-datastack" "kernel" } + { "set-retainstack" "kernel" } + { "set-callstack" "kernel" } + { "exit" "system" } + { "data-room" "memory" } + { "code-room" "memory" } + { "os-env" "system" } + { "millis" "system" } + { "type" "kernel.private" } + { "tag" "kernel.private" } + { "cwd" "io.files" } + { "cd" "io.files" } + { "modify-code-heap" "words.private" } + { "dlopen" "alien" } + { "dlsym" "alien" } + { "dlclose" "alien" } + { "" "byte-arrays" } + { "" "bit-arrays" } + { "" "alien" } + { "alien-signed-cell" "alien" } + { "set-alien-signed-cell" "alien" } + { "alien-unsigned-cell" "alien" } + { "set-alien-unsigned-cell" "alien" } + { "alien-signed-8" "alien" } + { "set-alien-signed-8" "alien" } + { "alien-unsigned-8" "alien" } + { "set-alien-unsigned-8" "alien" } + { "alien-signed-4" "alien" } + { "set-alien-signed-4" "alien" } + { "alien-unsigned-4" "alien" } + { "set-alien-unsigned-4" "alien" } + { "alien-signed-2" "alien" } + { "set-alien-signed-2" "alien" } + { "alien-unsigned-2" "alien" } + { "set-alien-unsigned-2" "alien" } + { "alien-signed-1" "alien" } + { "set-alien-signed-1" "alien" } + { "alien-unsigned-1" "alien" } + { "set-alien-unsigned-1" "alien" } + { "alien-float" "alien" } + { "set-alien-float" "alien" } + { "alien-double" "alien" } + { "set-alien-double" "alien" } + { "alien-cell" "alien" } + { "set-alien-cell" "alien" } + { "alien>char-string" "alien" } + { "string>char-alien" "alien" } + { "alien>u16-string" "alien" } + { "string>u16-alien" "alien" } + { "(throw)" "kernel.private" } + { "string>memory" "alien" } + { "memory>string" "alien" } + { "alien-address" "alien" } + { "slot" "slots.private" } + { "set-slot" "slots.private" } + { "char-slot" "strings.private" } + { "set-char-slot" "strings.private" } + { "resize-array" "arrays" } + { "resize-string" "strings" } + { "(hashtable)" "hashtables.private" } + { "" "arrays" } + { "begin-scan" "memory" } + { "next-object" "memory" } + { "end-scan" "memory" } + { "size" "memory" } + { "die" "kernel" } + { "fopen" "io.streams.c" } + { "fgetc" "io.streams.c" } + { "fread" "io.streams.c" } + { "fwrite" "io.streams.c" } + { "fflush" "io.streams.c" } + { "fclose" "io.streams.c" } + { "" "kernel" } + { "(clone)" "kernel" } + { "array>vector" "vectors.private" } + { "" "strings" } + { "(>tuple)" "tuples.private" } + { "array>quotation" "quotations.private" } + { "quotation-xt" "quotations" } + { "" "tuples.private" } + { "tuple>array" "tuples" } + { "profiling" "tools.profiler.private" } + { "become" "kernel.private" } + { "(sleep)" "threads.private" } + { "" "float-arrays" } + { "curry" "kernel" } + { "" "tuples.private" } + { "class-hash" "kernel.private" } + { "callstack>array" "kernel" } + { "innermost-frame-quot" "kernel.private" } + { "innermost-frame-scan" "kernel.private" } + { "set-innermost-frame-quot" "kernel.private" } + { "call-clear" "kernel" } + { "strip-compiled-quotations" "quotations" } + { "(os-envs)" "system" } +} +dup length [ >r first2 r> make-primitive ] 2each + ! Bump build number "build" "kernel" create build 1+ 1quotation define-compound diff --git a/core/classes/classes.factor b/core/classes/classes.factor index d9f2c71f74..47bf1b8f9c 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -253,8 +253,8 @@ PRIVATE> : (define-class) ( word props -- ) over reset-class + over define-symbol >r dup word-props r> union over set-word-props - dup intern-symbol t "class" set-word-prop ; : define-class ( word members superclass metaclass -- ) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 54aa751408..940de86d54 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -56,7 +56,7 @@ TUPLE: redefine-error def ; { { "Continue" t } } throw-restarts drop ; : add-once ( key assoc -- ) - 2dup key? [ drop redefine-error ] when dupd set-at ; + 2dup key? [ over redefine-error ] when dupd set-at ; : (remember-definition) ( definition loc assoc -- ) >r over set-where r> add-once ; @@ -65,6 +65,7 @@ TUPLE: redefine-error def ; new-definitions get first (remember-definition) ; : remember-class ( class loc -- ) + over new-definitions get first key? [ dup redefine-error ] when new-definitions get second (remember-definition) ; TUPLE: forward-error word ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f6d37af7b0..8b18969b7b 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -104,11 +104,6 @@ IN: temporary [ "OCT: 999" eval ] unit-test-fails [ "BIN: --0" eval ] unit-test-fails - [ f ] [ - "IN: temporary : foo ; TUPLE: foo ;" eval - "foo" "temporary" lookup symbol? - ] unit-test - ! Another funny bug [ t ] [ [ @@ -366,6 +361,13 @@ IN: temporary "redefining-a-class-3" parse-stream drop ] catch [ forward-error? ] is? ] unit-test + + [ t ] [ + [ + "IN: temporary : foo ; TUPLE: foo ;" + "redefining-a-class-4" parse-stream drop + ] catch [ redefine-error? ] is? + ] unit-test ] with-scope [ diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor old mode 100644 new mode 100755 index ce54bc6b9b..420d3bedbc --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -207,29 +207,28 @@ M: word declarations. : pprint-; \ ; pprint-word ; : (see) ( spec -- ) - [ - - dup definer nip [ pprint-word ] when* declarations. - block> - ] with-use nl ; + + dup definer nip [ pprint-word ] when* declarations. + block> ; -M: object see (see) ; +M: object see + [ (see) ] with-use nl ; GENERIC: see-class* ( word -- ) M: union-class see-class* - \ UNION: pprint-word + ; M: mixin-class see-class* - \ MIXIN: pprint-word + ; + ] curry* each block> block> ; M: predicate-class see-class* block> ; M: tuple-class see-class* - \ TUPLE: pprint-word + ; M: word see-class* drop ; @@ -265,8 +264,10 @@ M: builtin-class see-class* [ 2array ] curry map ; M: word see - dup (see) - dup see-class + [ + dup see-class* + dup class? over symbol? and not [ dup (see) ] when + ] with-use nl [ dup class? [ dup see-implementors % ] when dup generic? [ dup see-methods % ] when diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 14e3a48514..91e5bef1f8 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -241,10 +241,6 @@ HELP: define-symbol { $description "Defines the word to push itself on the stack when executed." } { $side-effects "word" } ; -HELP: intern-symbol -{ $values { "word" word } } -{ $description "If the word is undefined, makes it into a symbol which pushes itself on the stack when executed. If the word already has a definition, does nothing." } ; - HELP: define-compound { $values { "word" word } { "def" quotation } } { $description "Defines the word to call a quotation when executed." } diff --git a/core/words/words.factor b/core/words/words.factor index 28a89d467f..97027313a6 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -97,10 +97,8 @@ M: compound redefined* ( word -- ) PRIVATE> -: define-symbol ( word -- ) t define ; - -: intern-symbol ( word -- ) - dup undefined? [ define-symbol ] [ drop ] if ; +: define-symbol ( word -- ) + t define ; : define-compound ( word def -- ) [ ] like define ; From 73053ef2306a6fbcf791ed87c551751700b5f5fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Dec 2007 18:11:56 -0500 Subject: [PATCH 21/82] Add failing unit test --- core/prettyprint/prettyprint-tests.factor | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 2d959528ed..700c7ea33c 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -272,6 +272,20 @@ unit-test "another-narrow-layout" another-narrow-test check-see ] unit-test +: class-see-test + { + "IN: temporary" + "TUPLE: class-see-layout bar ;" + "GENERIC: class-see-layout" + "" + "USING: temporary ;" + "M: class-see-layout class-see-layout ;" + } ; + +[ t ] [ + "class-see-layout" class-see-test check-see +] unit-test + [ ] [ \ effect-in synopsis drop ] unit-test [ [ + ] ] [ From 423c22e4ef183f6c154d7299c4417574f0d51834 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Dec 2007 22:55:17 -0500 Subject: [PATCH 22/82] Symbols are compound defs now; SYMBOL: foo == : foo \ foo ; --- core/inference/backend/backend.factor | 2 -- core/words/words.factor | 14 ++++++++------ vm/cpu-arm.S | 4 ---- vm/cpu-arm.h | 1 - vm/cpu-ppc.S | 4 ---- vm/cpu-ppc.h | 1 - vm/cpu-x86.S | 5 ----- vm/cpu-x86.h | 1 - vm/run.c | 4 +--- 9 files changed, 9 insertions(+), 27 deletions(-) mode change 100644 => 100755 vm/cpu-ppc.S mode change 100644 => 100755 vm/cpu-x86.S mode change 100644 => 100755 vm/run.c diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index f65d637b02..e5f282a8d1 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -393,8 +393,6 @@ M: compound infer-word M: word apply-object apply-word ; -M: symbol apply-object apply-literal ; - TUPLE: recursive-declare-error word ; : declared-infer ( word -- ) diff --git a/core/words/words.factor b/core/words/words.factor index 97027313a6..972262675f 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -28,12 +28,14 @@ M: compound definer drop \ : \ ; ; M: compound definition word-def ; +PREDICATE: compound symbol ( obj -- ? ) + dup 1array swap word-def sequence= ; +M: symbol definer drop \ SYMBOL: f ; +M: symbol definition drop f ; + PREDICATE: word primitive ( obj -- ? ) word-def fixnum? ; M: primitive definer drop \ PRIMITIVE: f ; -PREDICATE: word symbol ( obj -- ? ) word-def t eq? ; -M: symbol definer drop \ SYMBOL: f ; - : word-prop ( word name -- value ) swap word-props at ; : remove-word-prop ( word name -- ) @@ -97,9 +99,6 @@ M: compound redefined* ( word -- ) PRIVATE> -: define-symbol ( word -- ) - t define ; - : define-compound ( word def -- ) [ ] like define ; @@ -119,6 +118,9 @@ PRIVATE> : define-inline ( word quot -- ) dupd define-compound make-inline ; +: define-symbol ( word -- ) + dup [ ] curry define-inline ; + : reset-word ( word -- ) { "parsing" "inline" "foldable" diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S index 35740f9c45..d98c033a4f 100755 --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -81,10 +81,6 @@ DEF(void,undefined,(CELL word)): sub r1,sp,#4 b MANGLE(undefined_error) -DEF(void,dosym,(CELL word)): - str r0,[r5, #4]! /* push word to stack */ - mov pc,lr /* return */ - /* Here we have two entry points. The first one is taken when profiling is enabled */ DEF(void,docol_profiling,(CELL word)): diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h index 8402824579..7da77e5e02 100755 --- a/vm/cpu-arm.h +++ b/vm/cpu-arm.h @@ -8,7 +8,6 @@ register CELL rs asm("r6"); #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) void c_to_factor(CELL quot); -void dosym(CELL word); void docol_profiling(CELL word); void docol(CELL word); void undefined(CELL word); diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S old mode 100644 new mode 100755 index 3c90fabca2..25b0ff0bd2 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -118,10 +118,6 @@ DEF(void,undefined,(CELL word)): mr r4,r1 b MANGLE(undefined_error) -DEF(void,dosym,(CELL word)): - stwu r3,4(r14) /* push word to stack */ - blr /* return */ - /* Here we have two entry points. The first one is taken when profiling is enabled */ DEF(void,docol_profiling,(CELL word)): diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h index 88bbde5661..da870d156c 100755 --- a/vm/cpu-ppc.h +++ b/vm/cpu-ppc.h @@ -5,7 +5,6 @@ register CELL ds asm("r14"); register CELL rs asm("r15"); void c_to_factor(CELL quot); -void dosym(CELL word); void docol_profiling(CELL word); void docol(CELL word); void undefined(CELL word); diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S old mode 100644 new mode 100755 index e912c65df6..f4fb5f5d31 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -21,11 +21,6 @@ DEF(F_FASTCALL void,undefined,(CELL word)): mov STACK_REG,ARG1 /* Pass callstack pointer */ jmp MANGLE(undefined_error) /* This throws an error */ -DEF(F_FASTCALL void,dosym,(CELL word)): - add $CELL_SIZE,DS_REG /* Increment stack pointer */ - mov ARG0,(DS_REG) /* Store word on stack */ - ret - /* Here we have two entry points. The first one is taken when profiling is enabled */ DEF(F_FASTCALL void,docol_profiling,(CELL word)): diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index 7983c139af..fe9c0f12db 100755 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -5,7 +5,6 @@ INLINE void flush_icache(CELL start, CELL len) {} F_FASTCALL void c_to_factor(CELL quot); F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); F_FASTCALL void undefined(CELL word); -F_FASTCALL void dosym(CELL word); F_FASTCALL void docol_profiling(CELL word); F_FASTCALL void docol(CELL word); F_FASTCALL void lazy_jit_compile(CELL quot); diff --git a/vm/run.c b/vm/run.c old mode 100644 new mode 100755 index 802ff4e8cc..afd50ec783 --- a/vm/run.c +++ b/vm/run.c @@ -265,9 +265,7 @@ DEFINE_PRIMITIVE(set_retainstack) XT default_word_xt(F_WORD *word) { - if(word->def == T) - return dosym; - else if(type_of(word->def) == QUOTATION_TYPE) + if(type_of(word->def) == QUOTATION_TYPE) { if(profiling_p()) return docol_profiling; From 3d784c7927e05cf294da7313704ca823d47c6ec8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Dec 2007 23:40:36 -0500 Subject: [PATCH 23/82] Simplify quotation calling convention: no need to pass XT --- core/bootstrap/image/image.factor | 3 ++ core/cpu/x86/32/bootstrap.factor | 1 - core/cpu/x86/bootstrap.factor | 82 +++++++++++++++---------------- core/cpu/x86/bootstrap.factor.new | 68 +++++++++++++++++++++++++ vm/code_heap.c | 16 +++--- vm/cpu-x86.S | 22 ++++----- vm/quotations.c | 21 +++++--- 7 files changed, 142 insertions(+), 71 deletions(-) mode change 100644 => 100755 core/cpu/x86/32/bootstrap.factor create mode 100755 core/cpu/x86/bootstrap.factor.new diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 20aa3af0be..5d74f5d9c6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -38,6 +38,9 @@ IN: bootstrap.image : quot-array@ bootstrap-cell object tag-number - ; : quot-xt@ 3 bootstrap-cells object tag-number - ; +: jit-define ( quot rc rt offset name -- ) + >r >r >r >r { } make r> r> r> 4array r> set ; + ! The image being constructed; a vector of word-size integers SYMBOL: image diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor old mode 100644 new mode 100755 index 32d07797e7..88a7028929 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -11,7 +11,6 @@ IN: bootstrap.x86 : stack-reg ESP ; : ds-reg ESI ; : scan-reg EBX ; -: xt-reg ECX ; : fixnum>slot@ arg0 1 SAR ; "resource:core/cpu/x86/bootstrap.factor" run-file diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 935ca1bad0..3c42814bcf 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs math ; +cpu.x86.assembler layouts vocabs math generator.fixup ; IN: bootstrap.x86 big-endian off @@ -13,77 +13,78 @@ big-endian off : scan-save stack-reg 3 bootstrap-cells [+] ; [ + ! arg0 0 MOV ! load quotation + arg1 arg0 quot-xt@ [+] MOV ! load XT arg0 arg0 quot-array@ [+] MOV ! load array scan-reg arg0 scan@ [+] LEA ! initialize scan pointer -] { } make jit-setup set +] rc-absolute-cell rt-literal 1 jit-setup jit-define -[ - stack-frame-size PUSH ! save stack frame size - xt-reg PUSH ! save XT +[ + stack-frame-size PUSH ! save stack frame size + arg1 PUSH ! save XT arg0 PUSH ! save array scan-reg PUSH ! initial scan stack-reg 3 bootstrap-cells SUB ! reserved -] { } make jit-prolog set - -: advance-scan scan-reg bootstrap-cell ADD ; - -[ - advance-scan +] f f f jit-prolog jit-define + +: advance-scan scan-reg bootstrap-cell ADD ; + +[ + advance-scan ds-reg bootstrap-cell ADD ! increment datastack pointer arg0 scan-reg [] MOV ! load literal ds-reg [] arg0 MOV ! store literal on datastack -] { } make jit-push-literal set +] f f f jit-push-literal jit-define -[ - advance-scan +[ + advance-scan ds-reg bootstrap-cell ADD ! increment datastack pointer arg0 scan-reg [] MOV ! load wrapper arg0 dup wrapper@ [+] MOV ! load wrapper-obj slot ds-reg [] arg0 MOV ! store literal on datastack -] { } make jit-push-wrapper set - -[ +] f f f jit-push-wrapper jit-define + +[ arg1 stack-reg MOV ! pass callstack pointer as arg 2 -] { } make jit-word-primitive-jump set - -[ +] f f f jit-word-primitive-jump jit-define + +[ arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2 -] { } make jit-word-primitive-call set - -[ +] f f f jit-word-primitive-call jit-define + +[ arg0 scan-reg bootstrap-cell [+] MOV ! load word arg0 word-xt@ [+] JMP ! jump to word XT -] { } make jit-word-jump set - -[ - advance-scan +] f f f jit-word-jump jit-define + +[ + advance-scan scan-save scan-reg MOV ! save scan pointer arg0 scan-reg [] MOV ! load word arg0 word-xt@ [+] CALL ! call word XT scan-reg scan-save MOV ! restore scan pointer -] { } make jit-word-call set - -: load-branch +] f f f jit-word-call jit-define + +: load-branch arg0 ds-reg [] MOV ! load boolean ds-reg bootstrap-cell SUB ! pop boolean arg0 \ f tag-number CMP ! compare it with f arg0 scan-reg 2 bootstrap-cells [+] CMOVE ! load false branch if equal arg0 scan-reg 1 bootstrap-cells [+] CMOVNE ! load true branch if not equal scan-reg 3 bootstrap-cells ADD ! advance scan pointer - xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt + arg0 quot-xt@ [+] ! load quotation-xt ; [ - load-branch - xt-reg JMP -] { } make jit-if-jump set + load-branch JMP +] f f f jit-if-jump jit-define [ load-branch scan-save scan-reg MOV ! save scan pointer - xt-reg CALL ! call quotation + CALL ! call quotation scan-reg scan-save MOV ! restore scan pointer -] { } make jit-if-call set +] f f f jit-if-call jit-define [ arg0 ds-reg [] MOV ! load index @@ -91,14 +92,13 @@ big-endian off ds-reg bootstrap-cell SUB ! pop index arg0 scan-reg bootstrap-cell [+] ADD ! compute quotation location arg0 arg0 array-start [+] MOV ! load quotation - xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt - xt-reg JMP ! execute quotation -] { } make jit-dispatch set + arg0 quot-xt@ [+] JMP ! jump to quotation-xt +] f f f jit-dispatch jit-define [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame -] { } make jit-epilog set +] f f f jit-epilog jit-define -[ 0 RET ] { } make jit-return set +[ 0 RET ] f f f jit-return jit-define "bootstrap.x86" forget-vocab diff --git a/core/cpu/x86/bootstrap.factor.new b/core/cpu/x86/bootstrap.factor.new new file mode 100755 index 0000000000..35aa34563d --- /dev/null +++ b/core/cpu/x86/bootstrap.factor.new @@ -0,0 +1,68 @@ +[! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private kernel namespaces system +cpu.x86.assembler layouts vocabs math ; +IN: bootstrap.x86 + +big-endian off + +1 jit-code-format set + +: stack-frame-size 4 bootstrap-cells ; + +[ + arg0 0 MOV + stack-frame-size PUSH ! save stack frame size + arg0 PUSH ! save XT + 0 PUSH ! reserved +] { } make jit-prolog set + +[ + arg0 0 [] MOV ! load literal + ds-reg bootstrap-cell ADD ! increment datastack pointer + ds-reg [] arg0 MOV ! store literal on datastack +] { } make jit-push-literal set + +[ + arg1 stack-reg MOV ! pass callstack pointer as arg 2 +] { } make jit-word-primitive-jump set + +[ + arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2 +] { } make jit-word-primitive-call set + +[ + 0 JMP +] { } make jit-word-jump set + +[ + 0 CALL +] { } make jit-word-call set + +[ + arg1 0 MOV ! load addr of true quotation + arg0 ds-reg [] MOV ! load boolean + ds-reg bootstrap-cell SUB ! pop boolean + arg0 \ f tag-number CMP ! compare it with f + arg0 arg1 [] CMOVE ! load false branch if equal + arg0 arg1 bootstrap-cell [+] CMOVNE ! load true branch if not equal + arg0 quot-xt@ [+] JMP ! execute branch +] { } make jit-if set + +[ + arg1 0 [] MOV ! load dispatch table + arg0 ds-reg [] MOV ! load index + fixnum>slot@ ! turn it into an array offset + ds-reg bootstrap-cell SUB ! pop index + arg0 arg1 ADD ! compute quotation location + arg0 arg0 array-start [+] MOV ! load quotation + arg0 quot-xt@ [+] JMP ! execute branch +] { } make jit-dispatch set + +[ + stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame +] { } make jit-epilog set + +[ 0 RET ] { } make jit-return set + +"bootstrap.x86" forget-vocab diff --git a/vm/code_heap.c b/vm/code_heap.c index 2c125cd345..3234a0c0bf 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -251,20 +251,20 @@ F_COMPILED *add_compiled_block( CELL profiler_prologue, F_ARRAY *code, F_ARRAY *labels, - F_ARRAY *rel, + F_ARRAY *relocation, F_ARRAY *words, F_ARRAY *literals) { CELL code_format = compiled_code_format(); CELL code_length = align8(array_capacity(code) * code_format); - CELL rel_length = (rel ? array_capacity(rel) * sizeof(unsigned int) : 0); + CELL rel_length = (relocation ? array_capacity(relocation) * sizeof(unsigned int) : 0); CELL words_length = (words ? array_capacity(words) * CELLS : 0); CELL literals_length = (literals ? array_capacity(literals) * CELLS : 0); REGISTER_UNTAGGED(code); REGISTER_UNTAGGED(labels); - REGISTER_UNTAGGED(rel); + REGISTER_UNTAGGED(relocation); REGISTER_UNTAGGED(words); REGISTER_UNTAGGED(literals); @@ -273,7 +273,7 @@ F_COMPILED *add_compiled_block( UNREGISTER_UNTAGGED(literals); UNREGISTER_UNTAGGED(words); - UNREGISTER_UNTAGGED(rel); + UNREGISTER_UNTAGGED(relocation); UNREGISTER_UNTAGGED(labels); UNREGISTER_UNTAGGED(code); @@ -295,9 +295,9 @@ F_COMPILED *add_compiled_block( here += code_length; /* relation info */ - if(rel) + if(relocation) { - deposit_integers(here,rel,sizeof(unsigned int)); + deposit_integers(here,relocation,sizeof(unsigned int)); here += rel_length; } @@ -365,7 +365,7 @@ DEFINE_PRIMITIVE(modify_code_heap) 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 *relocation = 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)); @@ -377,7 +377,7 @@ DEFINE_PRIMITIVE(modify_code_heap) profiler_prologue, code, labels, - rel, + relocation, words, literals); diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index f4fb5f5d31..96489954f7 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,6 +1,4 @@ -#define JUMP_QUOT \ - mov QUOT_XT_OFFSET(ARG0),XT_REG ; /* Load quot-xt */ \ - jmp *XT_REG /* Jump to quot-xt */ +#define JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0) DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE @@ -10,8 +8,7 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): call MANGLE(save_callstack_bottom) mov (STACK_REG),ARG0 /* Pass quot as arg 1 */ - mov QUOT_XT_OFFSET(ARG0),XT_REG - call *XT_REG /* Call quot-xt */ + call *QUOT_XT_OFFSET(ARG0) /* Call quot-xt */ POP ARG0 POP_NONVOLATILE @@ -40,8 +37,7 @@ callstack top parameter to primitives. */ DEF(F_FASTCALL void,primitive_execute,(void)): mov (DS_REG),ARG0 /* Load word from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ - mov WORD_XT_OFFSET(ARG0),XT_REG /* Load word-xt slot */ - jmp *XT_REG /* Go */ + jmp *WORD_XT_OFFSET(ARG0) /* Load word-xt slot */ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): mov ARG1,STACK_REG /* rewind_to */ @@ -49,14 +45,14 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): mov STACK_REG,ARG1 /* Save stack pointer */ - push XT_REG /* Alignment */ - push XT_REG - push XT_REG + push ARG1 /* Alignment */ + push ARG1 + push ARG1 call MANGLE(primitive_jit_compile) mov RETURN_REG,ARG0 /* No-op on 32-bit */ - pop XT_REG /* OK to clobber XT_REG here */ - pop XT_REG - pop XT_REG + pop ARG1 /* OK to clobber ARG1 here */ + pop ARG1 + pop ARG1 JUMP_QUOT /* Call the quotation */ #ifdef WINDOWS diff --git a/vm/quotations.c b/vm/quotations.c index 97baf2afe9..60c6d729d7 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -17,9 +17,14 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; } +F_ARRAY *code_to_emit(CELL name) +{ + return untag_object(array_nth(untag_object(userenv[name]),0)); +} + #define EMIT(name) { \ REGISTER_UNTAGGED(array); \ - GROWABLE_APPEND(result,untag_object(userenv[name])); \ + GROWABLE_APPEND(code,code_to_emit(name)); \ UNREGISTER_UNTAGGED(array); \ } @@ -54,7 +59,7 @@ void jit_compile(F_QUOTATION *quot) REGISTER_UNTAGGED(quot); REGISTER_UNTAGGED(array); - GROWABLE_ARRAY(result); + GROWABLE_ARRAY(code); UNREGISTER_UNTAGGED(array); bool stack_frame = jit_stack_frame_p(array); @@ -149,16 +154,16 @@ void jit_compile(F_QUOTATION *quot) EMIT(JIT_RETURN); } - GROWABLE_TRIM(result); + GROWABLE_TRIM(code); UNREGISTER_UNTAGGED(quot); REGISTER_UNTAGGED(quot); - REGISTER_UNTAGGED(result); + REGISTER_UNTAGGED(code); F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot)); - UNREGISTER_UNTAGGED(result); + UNREGISTER_UNTAGGED(code); - F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,0,result,NULL,NULL,NULL,literals); + F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,0,code,NULL,NULL,NULL,literals); iterate_code_heap_step(compiled,finalize_code_block); UNREGISTER_UNTAGGED(quot); @@ -181,11 +186,11 @@ XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset) CELL xt = 0; - xt += array_capacity(untag_array(userenv[JIT_SETUP])); + xt += array_capacity(code_to_emit(JIT_SETUP)); bool stack_frame = jit_stack_frame_p(untag_array(quot->array)); if(stack_frame) - xt += array_capacity(untag_array(userenv[JIT_PROLOG])); + xt += array_capacity(code_to_emit(JIT_PROLOG)); xt *= compiled_code_format(); From 500ec89b560e346eb40ec572f30951cd1c845153 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Dec 2007 23:45:04 -0500 Subject: [PATCH 24/82] Remove useless word --- core/arrays/arrays-docs.factor | 2 +- core/quotations/quotations-docs.factor | 4 ---- core/quotations/quotations.factor | 3 --- 3 files changed, 1 insertion(+), 8 deletions(-) mode change 100644 => 100755 core/arrays/arrays-docs.factor mode change 100644 => 100755 core/quotations/quotations.factor diff --git a/core/arrays/arrays-docs.factor b/core/arrays/arrays-docs.factor old mode 100644 new mode 100755 index 83a948a939..ff2a61473c --- a/core/arrays/arrays-docs.factor +++ b/core/arrays/arrays-docs.factor @@ -34,7 +34,7 @@ HELP: ( n elt -- array ) { $values { "n" "a non-negative integer" } { "elt" "an initial element" } { "array" "a new array" } } { $description "Creates a new array with the given length and all elements initially set to " { $snippet "elt" } "." } ; -{ } +{ } related-words HELP: >array diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 3a32b63ae9..c30db0a4b8 100755 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -27,10 +27,6 @@ HELP: callable HELP: quotation { $description "The class of quotations. See " { $link "syntax-quots" } " for syntax and " { $link "quotations" } " for general information." } ; -HELP: -{ $values { "n" "a non-negative integer" } { "quot" quotation } } -{ $description "Creates a new quotation with the given length and all elements initially set to " { $link f } "." } ; - HELP: >quotation { $values { "seq" "a sequence" } { "quot" quotation } } { $description "Outputs a freshly-allocated quotation with the same elements as a given sequence." } ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor old mode 100644 new mode 100755 index 061ff04889..64bf472704 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -12,9 +12,6 @@ UNION: callable quotation curry ; M: callable equal? over callable? [ sequence= ] [ 2drop f ] if ; -: ( n -- quot ) - f array>quotation ; inline - M: quotation length quotation-array length ; M: quotation nth-unsafe quotation-array nth-unsafe ; From c09af2f2c66460250c8ce440da98862f7b1131e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 01:45:16 -0500 Subject: [PATCH 25/82] Improved JIT compiler design; better REGISTER_ROOT/UNREGISTER_ROOT stuff --- core/cpu/x86/bootstrap.factor | 55 ++++----- core/generator/generator.factor | 6 +- vm/callstack.c | 2 +- vm/code_heap.c | 27 ++--- vm/data_gc.c | 17 ++- vm/data_gc.h | 30 ++++- vm/errors.c | 11 +- vm/os-unix.c | 12 +- vm/os-windows-nt.c | 6 +- vm/os-windows.c | 6 +- vm/quotations.c | 196 ++++++++++++++++++++------------ vm/quotations.h | 5 +- vm/run.c | 4 - vm/run.h | 3 - vm/types.h | 11 +- 15 files changed, 226 insertions(+), 165 deletions(-) mode change 100644 => 100755 vm/os-unix.c mode change 100644 => 100755 vm/quotations.h mode change 100644 => 100755 vm/run.h diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 3c42814bcf..13c2b2edf4 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -13,11 +13,11 @@ big-endian off : scan-save stack-reg 3 bootstrap-cells [+] ; [ - ! arg0 0 MOV ! load quotation + arg0 0 [] MOV ! load quotation arg1 arg0 quot-xt@ [+] MOV ! load XT arg0 arg0 quot-array@ [+] MOV ! load array scan-reg arg0 scan@ [+] LEA ! initialize scan pointer -] rc-absolute-cell rt-literal 1 jit-setup jit-define +] rc-absolute-cell rt-literal 2 jit-setup jit-define [ stack-frame-size PUSH ! save stack frame size @@ -30,27 +30,24 @@ big-endian off : advance-scan scan-reg bootstrap-cell ADD ; [ + arg0 0 [] MOV ! load literal advance-scan ds-reg bootstrap-cell ADD ! increment datastack pointer - arg0 scan-reg [] MOV ! load literal ds-reg [] arg0 MOV ! store literal on datastack -] f f f jit-push-literal jit-define - -[ - advance-scan - ds-reg bootstrap-cell ADD ! increment datastack pointer - arg0 scan-reg [] MOV ! load wrapper - arg0 dup wrapper@ [+] MOV ! load wrapper-obj slot - ds-reg [] arg0 MOV ! store literal on datastack -] f f f jit-push-wrapper jit-define +] rc-absolute-cell rt-literal 2 jit-push-literal jit-define [ arg1 stack-reg MOV ! pass callstack pointer as arg 2 -] f f f jit-word-primitive-jump jit-define + (JMP) drop ! go +] rc-relative rt-primitive 3 jit-word-primitive-jump jit-define [ + advance-scan arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2 -] f f f jit-word-primitive-call jit-define + scan-save scan-reg MOV ! save scan pointer + (CALL) drop ! go + scan-reg scan-save MOV ! restore scan pointer +] rc-relative rt-primitive 12 jit-word-primitive-call jit-define [ arg0 scan-reg bootstrap-cell [+] MOV ! load word @@ -65,35 +62,25 @@ big-endian off scan-reg scan-save MOV ! restore scan pointer ] f f f jit-word-call jit-define -: load-branch +[ + arg1 0 MOV ! load addr of true quotation arg0 ds-reg [] MOV ! load boolean ds-reg bootstrap-cell SUB ! pop boolean arg0 \ f tag-number CMP ! compare it with f - arg0 scan-reg 2 bootstrap-cells [+] CMOVE ! load false branch if equal - arg0 scan-reg 1 bootstrap-cells [+] CMOVNE ! load true branch if not equal - scan-reg 3 bootstrap-cells ADD ! advance scan pointer - arg0 quot-xt@ [+] ! load quotation-xt - ; - -[ - load-branch JMP -] f f f jit-if-jump jit-define - -[ - load-branch - scan-save scan-reg MOV ! save scan pointer - CALL ! call quotation - scan-reg scan-save MOV ! restore scan pointer -] f f f jit-if-call jit-define + arg0 arg1 [] CMOVNE ! load true branch if not equal + arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal + arg0 quot-xt@ [+] JMP ! jump to quotation-xt +] rc-absolute-cell rt-literal 1 jit-if-jump jit-define [ + arg1 0 [] MOV ! load dispatch table arg0 ds-reg [] MOV ! load index fixnum>slot@ ! turn it into an array offset ds-reg bootstrap-cell SUB ! pop index - arg0 scan-reg bootstrap-cell [+] ADD ! compute quotation location + arg0 arg1 ADD ! compute quotation location arg0 arg0 array-start [+] MOV ! load quotation - arg0 quot-xt@ [+] JMP ! jump to quotation-xt -] f f f jit-dispatch jit-define + arg0 quot-xt@ [+] JMP ! execute branch +] rc-absolute-cell rt-literal 2 jit-dispatch jit-define [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 4128559d35..a1a9c9be81 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -15,7 +15,7 @@ SYMBOL: compiled : begin-compiling ( word -- ) f swap compiled get set-at ; -: finish-compiling ( word literals words rel labels code profiler-prologue -- ) +: finish-compiling ( word literals words relocation labels code profiler-prologue -- ) 6array swap compiled get set-at ; : queue-compile ( word -- ) @@ -39,10 +39,10 @@ SYMBOL: compiled-stack-traces? t compiled-stack-traces? set-global -: init-generator ( -- ) +: init-generator ( compiling -- ) V{ } clone literal-table set V{ } clone word-table set - compiled-stack-traces? get compiling-word get f ? + compiled-stack-traces? get swap f ? literal-table get push ; : generate-1 ( word label node quot -- ) diff --git a/vm/callstack.c b/vm/callstack.c index 536be88bda..a53578f78c 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -205,7 +205,7 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot) REGISTER_UNTAGGED(quot); if(quot->compiledp == F) - jit_compile(quot); + jit_compile(tag_object(quot)); UNREGISTER_UNTAGGED(quot); UNREGISTER_UNTAGGED(callstack); diff --git a/vm/code_heap.c b/vm/code_heap.c index 3234a0c0bf..51833703cb 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -258,9 +258,9 @@ F_COMPILED *add_compiled_block( CELL code_format = compiled_code_format(); CELL code_length = align8(array_capacity(code) * code_format); - CELL rel_length = (relocation ? array_capacity(relocation) * sizeof(unsigned int) : 0); - CELL words_length = (words ? array_capacity(words) * CELLS : 0); - CELL literals_length = (literals ? array_capacity(literals) * CELLS : 0); + CELL rel_length = array_capacity(relocation) * sizeof(unsigned int); + CELL words_length = array_capacity(words) * CELLS; + CELL literals_length = array_capacity(literals) * CELLS; REGISTER_UNTAGGED(code); REGISTER_UNTAGGED(labels); @@ -295,25 +295,16 @@ F_COMPILED *add_compiled_block( here += code_length; /* relation info */ - if(relocation) - { - deposit_integers(here,relocation,sizeof(unsigned int)); - here += rel_length; - } + deposit_integers(here,relocation,sizeof(unsigned int)); + here += rel_length; /* literals */ - if(literals) - { - deposit_objects(here,literals); - here += literals_length; - } + deposit_objects(here,literals); + here += literals_length; /* words */ - if(words) - { - deposit_objects(here,words); - here += words_length; - } + deposit_objects(here,words); + here += words_length; /* fixup labels */ if(labels) diff --git a/vm/data_gc.c b/vm/data_gc.c index 8016ad4234..6d953134dc 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -126,6 +126,9 @@ void init_data_heap(CELL gens, { set_data_heap(alloc_data_heap(gens,young_size,aging_size)); + gc_locals_region = alloc_segment(getpagesize()); + gc_locals = gc_locals_region->start - CELLS; + extra_roots_region = alloc_segment(getpagesize()); extra_roots = extra_roots_region->start - CELLS; @@ -369,10 +372,9 @@ void collect_cards(void) /* Copy all tagged pointers in a range of memory */ void collect_stack(F_SEGMENT *region, CELL top) { - CELL bottom = region->start; - CELL ptr; + CELL ptr = region->start; - for(ptr = bottom; ptr <= top; ptr += CELLS) + for(; ptr <= top; ptr += CELLS) copy_handle((CELL*)ptr); } @@ -398,6 +400,14 @@ void collect_callstack(F_CONTEXT *stacks) iterate_callstack(top,bottom,collect_stack_frame); } +void collect_gc_locals(void) +{ + CELL ptr = gc_locals_region->start; + + for(; ptr <= gc_locals; ptr += CELLS) + copy_handle(*(CELL **)ptr); +} + /* Copy roots over at the start of GC, namely various constants, stacks, the user environment and extra roots registered with REGISTER_ROOT */ void collect_roots(void) @@ -407,6 +417,7 @@ void collect_roots(void) copy_handle(&bignum_pos_one); copy_handle(&bignum_neg_one); + collect_gc_locals(); collect_stack(extra_roots_region,extra_roots); save_stacks(); diff --git a/vm/data_gc.h b/vm/data_gc.h index ae11c5746a..d9c3d8eb1c 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -228,14 +228,38 @@ void garbage_collection(volatile CELL gen, /* If a runtime function needs to call another function which potentially allocates memory, it must store any local variable references to Factor objects on the root stack */ + +/* GC locals: stores addresses of pointers to objects. The GC updates these +pointers, so you can do + +REGISTER_ROOT(some_local); + +... allocate memory ... + +foo(some_local); + +... + +UNREGISTER_ROOT(some_local); */ +F_SEGMENT *gc_locals_region; +CELL gc_locals; + +DEFPUSHPOP(gc_local_,gc_locals) + +#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj) +#define UNREGISTER_ROOT(obj) \ + { \ + if(gc_local_pop() != (CELL)&obj) \ + critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \ + } + +/* Extra roots: stores pointers to objects in the heap. Requires extra work +(you have to unregister before accessing the object) but more flexible. */ F_SEGMENT *extra_roots_region; CELL extra_roots; DEFPUSHPOP(root_,extra_roots) -#define REGISTER_ROOT(obj) root_push(obj) -#define UNREGISTER_ROOT(obj) obj = root_pop() - #define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0) #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop()) diff --git a/vm/errors.c b/vm/errors.c index d306ea1aff..e82942af55 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -23,7 +23,8 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) gc_off = false; /* Reset local roots */ - extra_roots = stack_chain->extra_roots; + gc_locals = gc_locals_region->start - CELLS; + extra_roots = extra_roots_region->start - CELLS; /* If we had an underflow or overflow, stack pointers might be out of bounds */ @@ -104,10 +105,14 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) general_error(ERROR_RS_OVERFLOW,F,F,native_stack); else if(in_page(addr, nursery->end, 0, 0)) critical_error("allot_object() missed GC check",0); + else if(in_page(addr, gc_locals_region->start, 0, -1)) + critical_error("gc locals underflow",0); + else if(in_page(addr, gc_locals_region->end, 0, 0)) + critical_error("gc locals overflow",0); else if(in_page(addr, extra_roots_region->start, 0, -1)) - critical_error("local root underflow",0); + critical_error("extra roots underflow",0); else if(in_page(addr, extra_roots_region->end, 0, 0)) - critical_error("local root overflow",0); + critical_error("extra roots overflow",0); else general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); } diff --git a/vm/os-unix.c b/vm/os-unix.c old mode 100644 new mode 100755 index b33c879d88..55d55f312b --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -94,6 +94,7 @@ DEFINE_PRIMITIVE(read_dir) { DIR* dir = opendir(unbox_char_string()); GROWABLE_ARRAY(result); + REGISTER_ROOT(result); if(dir != NULL) { @@ -101,18 +102,17 @@ DEFINE_PRIMITIVE(read_dir) while((file = readdir(dir)) != NULL) { - REGISTER_UNTAGGED(result); CELL pair = parse_dir_entry(file); - UNREGISTER_UNTAGGED(result); GROWABLE_ADD(result,pair); } closedir(dir); } + UNREGISTER_ROOT(result); GROWABLE_TRIM(result); - dpush(tag_object(result)); + dpush(result); } DEFINE_PRIMITIVE(cwd) @@ -131,19 +131,19 @@ DEFINE_PRIMITIVE(cd) DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); + REGISTER_ROOT(result); char **env = environ; while(*env) { - REGISTER_UNTAGGED(result); CELL string = tag_object(from_char_string(*env)); - UNREGISTER_UNTAGGED(result); GROWABLE_ADD(result,string); env++; } + UNREGISTER_ROOT(result); GROWABLE_TRIM(result); - dpush(tag_object(result)); + dpush(result); } F_SEGMENT *alloc_segment(CELL size) diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 2b08d5f394..e356c2f674 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -26,6 +26,7 @@ DEFINE_PRIMITIVE(cd) DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); + REGISTER_ROOT(result); TCHAR *env = GetEnvironmentStrings(); TCHAR *finger = env; @@ -38,9 +39,7 @@ DEFINE_PRIMITIVE(os_envs) if(scan == finger) break; - REGISTER_UNTAGGED(result); CELL string = tag_object(from_u16_string(finger)); - UNREGISTER_UNTAGGED(result); GROWABLE_ADD(result,string); finger = scan + 1; @@ -48,8 +47,9 @@ DEFINE_PRIMITIVE(os_envs) FreeEnvironmentStrings(env); + UNREGISTER_ROOT(result); GROWABLE_TRIM(result); - dpush(tag_object(result)); + dpush(result); } long exception_handler(PEXCEPTION_POINTERS pe) diff --git a/vm/os-windows.c b/vm/os-windows.c index 9d7bd85465..54baf56212 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -173,25 +173,25 @@ DEFINE_PRIMITIVE(read_dir) F_CHAR *path = unbox_u16_string(); GROWABLE_ARRAY(result); + REGISTER_ROOT(result); if(INVALID_HANDLE_VALUE != (dir = FindFirstFile(path, &find_data))) { do { - REGISTER_UNTAGGED(result); CELL name = tag_object(from_u16_string(find_data.cFileName)); CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); CELL pair = allot_array_2(name,dirp); - UNREGISTER_UNTAGGED(result); GROWABLE_ADD(result,pair); } while (FindNextFile(dir, &find_data)); CloseHandle(dir); } + UNREGISTER_ROOT(result); GROWABLE_TRIM(result); - dpush(tag_object(result)); + dpush(result); } F_SEGMENT *alloc_segment(CELL size) diff --git a/vm/quotations.c b/vm/quotations.c index 60c6d729d7..2810eb5121 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -5,7 +5,7 @@ the second one is written in Factor and performs a lot of optimizations. See core/compiler/compiler.factor */ bool jit_fast_if_p(F_ARRAY *array, CELL i) { - return (i + 3) <= array_capacity(array) + return (i + 3) == array_capacity(array) && type_of(array_nth(array,i)) == QUOTATION_TYPE && type_of(array_nth(array,i + 1)) == QUOTATION_TYPE && array_nth(array,i + 2) == userenv[JIT_IF_WORD]; @@ -14,6 +14,7 @@ bool jit_fast_if_p(F_ARRAY *array, CELL i) bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) { return (i + 2) == array_capacity(array) + && type_of(array_nth(array,i)) == ARRAY_TYPE && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; } @@ -22,10 +23,44 @@ F_ARRAY *code_to_emit(CELL name) return untag_object(array_nth(untag_object(userenv[name]),0)); } -#define EMIT(name) { \ - REGISTER_UNTAGGED(array); \ +F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length, + CELL rel_argument, bool *rel_p) +{ + F_ARRAY *quadruple = untag_object(userenv[name]); + CELL rel_class = array_nth(quadruple,1); + CELL rel_type = array_nth(quadruple,2); + CELL offset = array_nth(quadruple,3); + + F_REL rel; + + if(rel_class == F) + { + *rel_p = false; + rel.type = 0; + rel.offset = 0; + } + else + { + *rel_p = true; + rel.type = to_fixnum(rel_type) + | (to_fixnum(rel_class) << 8) + | (rel_argument << 16); + rel.offset = code_length * code_format + to_fixnum(offset); + } + + return rel; +} + +#define EMIT(name,rel_argument) { \ + bool rel_p; \ + F_REL rel = rel_to_emit(name,code_format,code_count, \ + rel_argument,&rel_p); \ + if(rel_p) \ + { \ + GROWABLE_ADD(relocation,allot_cell(rel.type)); \ + GROWABLE_ADD(relocation,allot_cell(rel.offset)); \ + } \ GROWABLE_APPEND(code,code_to_emit(name)); \ - UNREGISTER_UNTAGGED(array); \ } bool jit_stack_frame_p(F_ARRAY *array) @@ -52,32 +87,47 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code) quot->compiledp = T; } -void jit_compile(F_QUOTATION *quot) +/* Might GC */ +void jit_compile(CELL quot) { - F_ARRAY *array = untag_object(quot->array); + CELL code_format = compiled_code_format(); - REGISTER_UNTAGGED(quot); + REGISTER_ROOT(quot); + + CELL array = untag_quotation(quot)->array; + REGISTER_ROOT(array); - REGISTER_UNTAGGED(array); GROWABLE_ARRAY(code); - UNREGISTER_UNTAGGED(array); + REGISTER_ROOT(code); - bool stack_frame = jit_stack_frame_p(array); + GROWABLE_ARRAY(relocation); + REGISTER_ROOT(relocation); - EMIT(JIT_SETUP); + GROWABLE_ARRAY(literals); + REGISTER_ROOT(literals); + + GROWABLE_ARRAY(words); + REGISTER_ROOT(words); + + GROWABLE_ADD(literals,quot); + + bool stack_frame = jit_stack_frame_p(untag_object(array)); + + EMIT(JIT_SETUP,0); if(stack_frame) - EMIT(JIT_PROLOG); + EMIT(JIT_PROLOG,0); CELL i; - CELL length = array_capacity(array); + CELL length = array_capacity(untag_object(array)); bool tail_call = false; for(i = 0; i < length; i++) { - CELL obj = array_nth(array,i); + CELL obj = array_nth(untag_object(array),i); F_WORD *word; bool primitive_p; + F_WRAPPER *wrapper; switch(type_of(obj)) { @@ -91,57 +141,65 @@ void jit_compile(F_QUOTATION *quot) if(i == length - 1) { if(stack_frame) - EMIT(JIT_EPILOG); + EMIT(JIT_EPILOG,0); if(primitive_p) - EMIT(JIT_WORD_PRIMITIVE_JUMP); - - EMIT(JIT_WORD_JUMP); + { + EMIT(JIT_WORD_PRIMITIVE_JUMP, + to_fixnum(word->def)); + } + else + EMIT(JIT_WORD_JUMP,0); tail_call = true; } else { if(primitive_p) - EMIT(JIT_WORD_PRIMITIVE_CALL); - - EMIT(JIT_WORD_CALL); + { + EMIT(JIT_WORD_PRIMITIVE_CALL, + to_fixnum(word->def)); + } + else + EMIT(JIT_WORD_CALL,0); } break; case WRAPPER_TYPE: - EMIT(JIT_PUSH_WRAPPER); + wrapper = untag_object(obj); + GROWABLE_ADD(literals,wrapper->object); + EMIT(JIT_PUSH_LITERAL,literals_count - 1); break; case QUOTATION_TYPE: - if(jit_fast_if_p(array,i)) + if(jit_fast_if_p(untag_object(array),i)) { + if(stack_frame) + EMIT(JIT_EPILOG,0); + + GROWABLE_ADD(literals,array_nth(untag_object(array),i)); + GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1)); + EMIT(JIT_IF_JUMP,literals_count - 2); + i += 2; - if(i == length - 1) - { - if(stack_frame) - EMIT(JIT_EPILOG); - EMIT(JIT_IF_JUMP); - tail_call = true; - } - else - EMIT(JIT_IF_CALL); - + tail_call = true; break; } case ARRAY_TYPE: - if(jit_fast_dispatch_p(array,i)) + if(jit_fast_dispatch_p(untag_object(array),i)) { - i++; - if(stack_frame) - EMIT(JIT_EPILOG); + EMIT(JIT_EPILOG,0); - EMIT(JIT_DISPATCH); + GROWABLE_ADD(literals,array_nth(untag_object(array),i)); + EMIT(JIT_DISPATCH,literals_count - 1); + + i++; tail_call = true; break; } default: - EMIT(JIT_PUSH_LITERAL); + GROWABLE_ADD(literals,obj); + EMIT(JIT_PUSH_LITERAL,literals_count - 1); break; } } @@ -149,52 +207,44 @@ void jit_compile(F_QUOTATION *quot) if(!tail_call) { if(stack_frame) - EMIT(JIT_EPILOG); + EMIT(JIT_EPILOG,0); - EMIT(JIT_RETURN); + EMIT(JIT_RETURN,0); } GROWABLE_TRIM(code); + GROWABLE_TRIM(relocation); + GROWABLE_TRIM(literals); + GROWABLE_TRIM(words); - UNREGISTER_UNTAGGED(quot); - REGISTER_UNTAGGED(quot); + F_COMPILED *compiled = add_compiled_block( + QUOTATION_TYPE, + 0, + untag_object(code), + NULL, + untag_object(relocation), + untag_object(words), + untag_object(literals)); - REGISTER_UNTAGGED(code); - F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot)); - UNREGISTER_UNTAGGED(code); - - F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,0,code,NULL,NULL,NULL,literals); iterate_code_heap_step(compiled,finalize_code_block); - UNREGISTER_UNTAGGED(quot); - set_quot_xt(quot,compiled); + set_quot_xt(untag_object(quot),compiled); + + UNREGISTER_ROOT(words); + UNREGISTER_ROOT(literals); + UNREGISTER_ROOT(relocation); + UNREGISTER_ROOT(code); + UNREGISTER_ROOT(array); + UNREGISTER_ROOT(quot); } -F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack) +F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) { stack_chain->callstack_top = stack; - REGISTER_ROOT(tagged); - jit_compile(untag_quotation(tagged)); - UNREGISTER_ROOT(tagged); - return tagged; -} - -XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset) -{ - if(offset != -1) - critical_error("Not yet implemented",0); - - CELL xt = 0; - - xt += array_capacity(code_to_emit(JIT_SETUP)); - - bool stack_frame = jit_stack_frame_p(untag_array(quot->array)); - if(stack_frame) - xt += array_capacity(code_to_emit(JIT_PROLOG)); - - xt *= compiled_code_format(); - - return quot->xt + xt; + REGISTER_ROOT(quot); + jit_compile(quot); + UNREGISTER_ROOT(quot); + return quot; } DEFINE_PRIMITIVE(curry) diff --git a/vm/quotations.h b/vm/quotations.h old mode 100644 new mode 100755 index e8da6093cd..ebbacb8f45 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,7 +1,6 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); -void jit_compile(F_QUOTATION *quot); -F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack); -XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset); +void jit_compile(CELL quot); +F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); void uncurry(CELL obj); DECLARE_PRIMITIVE(curry); DECLARE_PRIMITIVE(array_to_quotation); diff --git a/vm/run.c b/vm/run.c index afd50ec783..13e9ba76ba 100755 --- a/vm/run.c +++ b/vm/run.c @@ -54,8 +54,6 @@ void nest_stacks(void) new_stacks->datastack_region = alloc_segment(ds_size); new_stacks->retainstack_region = alloc_segment(rs_size); - new_stacks->extra_roots = extra_roots; - new_stacks->next = stack_chain; stack_chain = new_stacks; @@ -76,8 +74,6 @@ void unnest_stacks(void) userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; - extra_roots = stack_chain->extra_roots; - F_CONTEXT *old_stacks = stack_chain; stack_chain = old_stacks->next; free(old_stacks); diff --git a/vm/run.h b/vm/run.h old mode 100644 new mode 100755 index 7075999b7f..45810f6fa7 --- a/vm/run.h +++ b/vm/run.h @@ -183,9 +183,6 @@ typedef struct _F_CONTEXT { CELL catchstack_save; CELL current_callback_save; - /* saved extra_roots pointer on entry to callback */ - CELL extra_roots; - struct _F_CONTEXT *next; } F_CONTEXT; diff --git a/vm/types.h b/vm/types.h index 78c42d3a54..de3c46f563 100755 --- a/vm/types.h +++ b/vm/types.h @@ -194,7 +194,7 @@ DECLARE_PRIMITIVE(wrapper); /* Macros to simulate a vector in C */ #define GROWABLE_ARRAY(result) \ CELL result##_count = 0; \ - F_ARRAY *result = allot_array(ARRAY_TYPE,100,F) + CELL result = tag_object(allot_array(ARRAY_TYPE,100,F)) INLINE F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) { @@ -214,7 +214,7 @@ INLINE F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) } #define GROWABLE_ADD(result,elt) \ - result = growable_add(result,elt,&result##_count) + result = tag_object(growable_add(untag_object(result),elt,&result##_count)) INLINE F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) { @@ -236,6 +236,7 @@ INLINE F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_cou } #define GROWABLE_APPEND(result,elts) \ - result = growable_append(result,elts,&result##_count) - -#define GROWABLE_TRIM(result) result = reallot_array(result,result##_count,F) + result = tag_object(growable_append(untag_object(result),elts,&result##_count)) + +#define GROWABLE_TRIM(result) \ + result = tag_object(reallot_array(untag_object(result),result##_count,F)) From 4bb2a43a105a8a3cfad3a51749a7a5699bb0b8f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 02:33:49 -0500 Subject: [PATCH 26/82] Early binding JIT work in progress --- core/cpu/x86/bootstrap.factor | 10 ++++------ vm/code_gc.c | 4 +++- vm/code_heap.c | 26 ++++++++++++++----------- vm/data_gc.c | 2 +- vm/factor.c | 36 +++++++++++++++++++++++++++++++++++ vm/image.c | 23 ++++++++++++++++++---- vm/profiler.c | 17 +++++++---------- vm/quotations.c | 14 ++++++++++++-- vm/run.c | 22 ++++++++++++++------- vm/run.h | 22 ++++++++++++--------- vm/types.c | 2 +- vm/types.h | 5 +++++ 12 files changed, 131 insertions(+), 52 deletions(-) mode change 100644 => 100755 vm/profiler.c diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 13c2b2edf4..7fe10b7ec3 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -50,17 +50,15 @@ big-endian off ] rc-relative rt-primitive 12 jit-word-primitive-call jit-define [ - arg0 scan-reg bootstrap-cell [+] MOV ! load word - arg0 word-xt@ [+] JMP ! jump to word XT -] f f f jit-word-jump jit-define + (JMP) drop +] rc-relative rt-xt 1 jit-word-jump jit-define [ advance-scan scan-save scan-reg MOV ! save scan pointer - arg0 scan-reg [] MOV ! load word - arg0 word-xt@ [+] CALL ! call word XT + (CALL) drop scan-reg scan-save MOV ! restore scan pointer -] f f f jit-word-call jit-define +] rc-relative rt-xt 8 jit-word-call jit-define [ arg1 0 MOV ! load addr of true quotation diff --git a/vm/code_gc.c b/vm/code_gc.c index 8ae3ea5eda..be7ab2e8a7 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -378,7 +378,7 @@ void forward_object_xts(void) { F_WORD *word = untag_object(obj); - if(word->compiledp != F) + if(word_references_code_heap_p(word)) word->code = forward_xt(word->code); } else if(type_of(obj) == QUOTATION_TYPE) @@ -414,6 +414,8 @@ void fixup_object_xts(void) if(word->compiledp != F) set_word_xt(word,word->code); + else + word->xt = word->code + sizeof(F_COMPILED); } else if(type_of(obj) == QUOTATION_TYPE) { diff --git a/vm/code_heap.c b/vm/code_heap.c index 51833703cb..783709d89f 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -38,11 +38,6 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) static CELL xt_offset; -void incompatible_call_error(void) -{ - critical_error("Calling non-optimized word from optimized word",0); -} - /* Compute an address to store at a relocation */ INLINE CELL compute_code_rel(F_REL *rel, CELL code_start, CELL literals_start, CELL words_start) @@ -62,15 +57,12 @@ INLINE CELL compute_code_rel(F_REL *rel, case RT_XT: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); if(word->compiledp == F) - return (CELL)incompatible_call_error; + return (CELL)word->code + sizeof(F_COMPILED); else return (CELL)word->code + sizeof(F_COMPILED) + xt_offset; case RT_XT_PROFILING: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - if(word->compiledp == F) - return (CELL)incompatible_call_error; - else - return (CELL)word->code + sizeof(F_COMPILED); + return (CELL)word->code + sizeof(F_COMPILED); case RT_LABEL: return code_start + REL_ARGUMENT(rel); default: @@ -347,7 +339,19 @@ DEFINE_PRIMITIVE(modify_code_heap) if(data == F) { word->compiledp = F; - word->xt = default_word_xt(word); + + if(type_of(word->def) == QUOTATION_TYPE) + { + REGISTER_UNTAGGED(alist); + REGISTER_UNTAGGED(word); + + jit_compile(word->def); + + UNREGISTER_UNTAGGED(word); + UNREGISTER_UNTAGGED(alist); + } + + default_word_xt(word); } else { diff --git a/vm/data_gc.c b/vm/data_gc.c index 6d953134dc..ab9bb509a0 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -557,7 +557,7 @@ CELL collect_next(CELL scan) { case WORD_TYPE: word = (F_WORD *)scan; - if(collecting_code && word->compiledp != F) + if(collecting_code && word_references_code_heap_p(word)) recursive_mark(compiled_to_block(word->code)); break; case QUOTATION_TYPE: diff --git a/vm/factor.c b/vm/factor.c index 8719416b72..5aa4beafbf 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -29,6 +29,39 @@ void default_parameters(F_PARAMETERS *p) p->console = false; } +/* Do some initialization that we do once only */ +void do_stage1_init(void) +{ + fprintf(stderr,"*** Starting stage 2 early init...\n"); + fflush(stderr); + + begin_scan(); + + CELL obj; + while((obj = next_object()) != F) + { + if(type_of(obj) == WORD_TYPE) + { + F_WORD *word = untag_object(obj); + if(type_of(word->def) == QUOTATION_TYPE) + { + jit_compile(word->def); + default_word_xt(word); + } + } + } + + /* End heap scan */ + gc_off = false; + + iterate_code_heap(finalize_code_block); + + userenv[STAGE2_ENV] = T; + + fprintf(stderr,"*** Finished stage 2 early init\n"); + fflush(stderr); +} + /* Get things started */ void init_factor(F_PARAMETERS *p) { @@ -69,6 +102,9 @@ void init_factor(F_PARAMETERS *p) /* We can GC now */ gc_off = false; + + if(!stage2) + do_stage1_init(); } INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) diff --git a/vm/image.c b/vm/image.c index d5ee02cca0..fab37d6303 100755 --- a/vm/image.c +++ b/vm/image.c @@ -9,6 +9,8 @@ void init_objects(F_HEADER *h) bignum_zero = h->bignum_zero; bignum_pos_one = h->bignum_pos_one; bignum_neg_one = h->bignum_neg_one; + + stage2 = (userenv[STAGE2_ENV] != F); } INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) @@ -176,12 +178,25 @@ void fixup_word(F_WORD *word) /* If this is a compiled word, relocate the code pointer. Otherwise, reset it based on the primitive number of the word. */ if(word->compiledp == F) - word->xt = default_word_xt(word); - else { - code_fixup((CELL)&word->xt); - code_fixup((CELL)&word->code); + if(type_of(word->def) == QUOTATION_TYPE) + { + if(!stage2) + { + /* Word XTs are fixed up in do_stage1_init() */ + return; + } + } + else + { + /* Primitive or undefined */ + default_word_xt(word); + return; + } } + + code_fixup((CELL)&word->xt); + code_fixup((CELL)&word->code); } void fixup_quotation(F_QUOTATION *quot) diff --git a/vm/profiler.c b/vm/profiler.c old mode 100644 new mode 100755 index ec1eaf7582..2c23f2960f --- a/vm/profiler.c +++ b/vm/profiler.c @@ -8,16 +8,13 @@ bool profiling_p(void) void profiling_word(F_WORD *word) { /* If we just enabled the profiler, reset call count */ - if(profiling_p()) - word->counter = tag_fixnum(0); - - if(word->compiledp == F) - { - if(type_of(word->def) == QUOTATION_TYPE) - word->xt = default_word_xt(word); - } - else - set_word_xt(word,word->code); + // if(profiling_p()) + // word->counter = tag_fixnum(0); + // + // if(word->compiledp == F) + // default_word_xt(word); + // else + // set_word_xt(word,word->code); } void set_profiling(bool profiling) diff --git a/vm/quotations.c b/vm/quotations.c index 2810eb5121..fb209c345d 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -90,6 +90,9 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code) /* Might GC */ void jit_compile(CELL quot) { + if(untag_quotation(quot)->compiledp != F) + return; + CELL code_format = compiled_code_format(); REGISTER_ROOT(quot); @@ -149,7 +152,11 @@ void jit_compile(CELL quot) to_fixnum(word->def)); } else - EMIT(JIT_WORD_JUMP,0); + { + GROWABLE_ADD(words,array_nth(untag_object(array),i)); + EMIT(JIT_WORD_JUMP,words_count - 1); + } + tail_call = true; } else @@ -160,7 +167,10 @@ void jit_compile(CELL quot) to_fixnum(word->def)); } else - EMIT(JIT_WORD_CALL,0); + { + GROWABLE_ADD(words,array_nth(untag_object(array),i)); + EMIT(JIT_WORD_CALL,words_count - 1); + } } break; case WRAPPER_TYPE: diff --git a/vm/run.c b/vm/run.c index 13e9ba76ba..766f399328 100755 --- a/vm/run.c +++ b/vm/run.c @@ -259,19 +259,27 @@ DEFINE_PRIMITIVE(set_retainstack) rs = array_to_stack(untag_array(dpop()),rs_bot); } -XT default_word_xt(F_WORD *word) +void default_word_xt(F_WORD *word) { if(type_of(word->def) == QUOTATION_TYPE) { - if(profiling_p()) - return docol_profiling; - else - return docol; + F_QUOTATION *quot = untag_quotation(word->def); + if(quot->compiledp == F) + critical_error("default_word_xt invariant lost",0); + word->xt = quot->xt; + word->code = quot->code; + + //if(profiling_p()) + // word->xt = docol_profiling; + //else + // word->xt = docol; } else if(type_of(word->def) == FIXNUM_TYPE) - return primitives[to_fixnum(word->def)]; + word->xt = primitives[to_fixnum(word->def)]; + else if(word->def == F) + word->xt = undefined; else - return undefined; + critical_error("bad word-def",tag_object(word)); } DEFINE_PRIMITIVE(getenv) diff --git a/vm/run.h b/vm/run.h index 45810f6fa7..e4d6926771 100755 --- a/vm/run.h +++ b/vm/run.h @@ -7,21 +7,21 @@ typedef enum { CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */ WALKER_HOOK_ENV, /* non-local exit hook, used by library only */ CALLCC_1_ENV, /* used to pass the value in callcc1 */ - + BREAK_ENV = 5, /* quotation called by throw primitive */ ERROR_ENV, /* a marker consed onto kernel errors */ - + CELL_SIZE_ENV = 7, /* sizeof(CELL) */ CPU_ENV, /* CPU architecture */ OS_ENV, /* operating system name */ - + ARGS_ENV = 10, /* command line arguments */ IN_ENV, /* stdin FILE* handle */ OUT_ENV, /* stdout FILE* handle */ - + IMAGE_ENV = 13, /* image path name */ EXECUTABLE_ENV, /* runtime executable path name */ - + EMBEDDED_ENV = 15, /* are we embedded in another app? */ EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */ YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */ @@ -40,18 +40,20 @@ typedef enum { JIT_WORD_PRIMITIVE_CALL, JIT_WORD_JUMP, JIT_WORD_CALL, - JIT_PUSH_WRAPPER, + UNUSED_1, JIT_PUSH_LITERAL, JIT_IF_WORD, JIT_IF_JUMP, - JIT_IF_CALL, + UNUSED_2, JIT_DISPATCH_WORD, JIT_DISPATCH, JIT_EPILOG, JIT_RETURN, - /* Profiler support */ + /* Profiler support */ PROFILING_ENV = 38, /* is the profiler on? */ + + STAGE2_ENV = 39 /* Have we bootstrapped? */ } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV @@ -223,7 +225,7 @@ DECLARE_PRIMITIVE(from_r); DECLARE_PRIMITIVE(datastack); DECLARE_PRIMITIVE(retainstack); -XT default_word_xt(F_WORD *word); +void default_word_xt(F_WORD *word); DECLARE_PRIMITIVE(execute); DECLARE_PRIMITIVE(call); @@ -240,3 +242,5 @@ DECLARE_PRIMITIVE(tag); DECLARE_PRIMITIVE(class_hash); DECLARE_PRIMITIVE(slot); DECLARE_PRIMITIVE(set_slot); + +bool stage2; diff --git a/vm/types.c b/vm/types.c index 6e465ba28d..588e0f1ad6 100755 --- a/vm/types.c +++ b/vm/types.c @@ -463,7 +463,7 @@ F_WORD *allot_word(CELL vocab, CELL name) word->props = F; word->counter = tag_fixnum(0); word->compiledp = F; - word->xt = default_word_xt(word); + word->xt = undefined; return word; } diff --git a/vm/types.h b/vm/types.h index de3c46f563..684f1837bd 100755 --- a/vm/types.h +++ b/vm/types.h @@ -109,6 +109,11 @@ INLINE F_QUOTATION *untag_quotation(CELL tagged) return untag_object(tagged); } +INLINE bool word_references_code_heap_p(F_WORD *word) +{ + return (word->compiledp != F || type_of(word->def) == QUOTATION_TYPE); +} + INLINE F_WORD *untag_word(CELL tagged) { type_check(WORD_TYPE,tagged); From f91ec96425b3345d6ddfdfb7b2634d2b953a29bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 17:14:33 -0500 Subject: [PATCH 27/82] Fix code heap compaction and clean up VM a bit --- vm/code_gc.c | 2 +- vm/code_heap.c | 29 +++++++++++++++++------------ vm/code_heap.h | 3 --- vm/cpu-arm.h | 2 -- vm/cpu-ppc.h | 2 -- vm/cpu-x86.S | 12 +----------- vm/cpu-x86.h | 2 -- vm/factor.c | 2 +- vm/profiler.c | 7 ++----- vm/quotations.c | 2 +- vm/types.c | 36 ++++++++++++++++++++++++++++++++++++ vm/types.h | 36 ++---------------------------------- 12 files changed, 61 insertions(+), 74 deletions(-) mode change 100644 => 100755 vm/code_heap.h diff --git a/vm/code_gc.c b/vm/code_gc.c index be7ab2e8a7..7d340f21b0 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -415,7 +415,7 @@ void fixup_object_xts(void) if(word->compiledp != F) set_word_xt(word,word->code); else - word->xt = word->code + sizeof(F_COMPILED); + word->xt = (void *)(word->code + 1); } else if(type_of(obj) == QUOTATION_TYPE) { diff --git a/vm/code_heap.c b/vm/code_heap.c index 783709d89f..a472431879 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -138,22 +138,27 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value) void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) { - xt_offset = (profiling_p() ? 0 : relocating->profiler_prologue); - - F_REL *rel = (F_REL *)reloc_start; - F_REL *rel_end = (F_REL *)literals_start; - - while(rel < rel_end) + if(reloc_start != literals_start) { - CELL offset = rel->offset + code_start; + xt_offset = (profiling_p() ? 0 : relocating->profiler_prologue); - F_FIXNUM absolute_value = compute_code_rel(rel, - code_start,literals_start,words_start); + F_REL *rel = (F_REL *)reloc_start; + F_REL *rel_end = (F_REL *)literals_start; - apply_relocation(REL_CLASS(rel),offset,absolute_value); + while(rel < rel_end) + { + CELL offset = rel->offset + code_start; - rel++; + F_FIXNUM absolute_value = compute_code_rel(rel, + code_start,literals_start,words_start); + + apply_relocation(REL_CLASS(rel),offset,absolute_value); + + rel++; + } } + + flush_icache(code_start,reloc_start - code_start); } /* Fixup labels. This is done at compile time, not image load time */ @@ -384,5 +389,5 @@ DEFINE_PRIMITIVE(modify_code_heap) } if(count != 0) - iterate_code_heap(finalize_code_block); + iterate_code_heap(relocate_code_block); } diff --git a/vm/code_heap.h b/vm/code_heap.h old mode 100644 new mode 100755 index 7a0c0976c0..e187f72a4c --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -56,9 +56,6 @@ typedef struct { void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end); -void finalize_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end); - void set_word_xt(F_WORD *word, F_COMPILED *compiled); F_COMPILED *add_compiled_block( diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h index 7da77e5e02..c134389969 100755 --- a/vm/cpu-arm.h +++ b/vm/cpu-arm.h @@ -8,8 +8,6 @@ register CELL rs asm("r6"); #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) void c_to_factor(CELL quot); -void docol_profiling(CELL word); -void docol(CELL word); void undefined(CELL word); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); void throw_impl(CELL quot, F_STACK_FRAME *rewind); diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h index da870d156c..810aef8b5d 100755 --- a/vm/cpu-ppc.h +++ b/vm/cpu-ppc.h @@ -5,8 +5,6 @@ register CELL ds asm("r14"); register CELL rs asm("r15"); void c_to_factor(CELL quot); -void docol_profiling(CELL word); -void docol(CELL word); void undefined(CELL word); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); void throw_impl(CELL quot, F_STACK_FRAME *rewind); diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 96489954f7..eef540907e 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -18,22 +18,12 @@ DEF(F_FASTCALL void,undefined,(CELL word)): mov STACK_REG,ARG1 /* Pass callstack pointer */ jmp MANGLE(undefined_error) /* This throws an error */ -/* Here we have two entry points. The first one is taken when profiling is -enabled */ -DEF(F_FASTCALL void,docol_profiling,(CELL word)): - add $8,PROFILING_OFFSET(ARG0) /* Increment profile-count slot */ -DEF(F_FASTCALL void,docol,(CELL word)): - mov WORD_DEF_OFFSET(ARG0),ARG0 /* Load word-def slot */ - JUMP_QUOT - -/* We must pass the XT to the quotation in ECX. */ DEF(F_FASTCALL void,primitive_call,(void)): mov (DS_REG),ARG0 /* Load quotation from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ JUMP_QUOT -/* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the -callstack top parameter to primitives. */ +/* Don't mess up EDX, it's the callstack top parameter to primitives. */ DEF(F_FASTCALL void,primitive_execute,(void)): mov (DS_REG),ARG0 /* Load word from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index fe9c0f12db..e2c474808e 100755 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -5,8 +5,6 @@ INLINE void flush_icache(CELL start, CELL len) {} F_FASTCALL void c_to_factor(CELL quot); F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); F_FASTCALL void undefined(CELL word); -F_FASTCALL void docol_profiling(CELL word); -F_FASTCALL void docol(CELL word); F_FASTCALL void lazy_jit_compile(CELL quot); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); diff --git a/vm/factor.c b/vm/factor.c index 5aa4beafbf..864293e2f3 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -54,7 +54,7 @@ void do_stage1_init(void) /* End heap scan */ gc_off = false; - iterate_code_heap(finalize_code_block); + iterate_code_heap(relocate_code_block); userenv[STAGE2_ENV] = T; diff --git a/vm/profiler.c b/vm/profiler.c index 2c23f2960f..79b271dc44 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -27,7 +27,7 @@ void set_profiling(bool profiling) /* Push everything to tenured space so that we can heap scan */ data_gc(); - /* Step 1 - Update word XTs and saved callstack objects */ + /* Update word XTs and saved callstack objects */ begin_scan(); CELL obj; @@ -39,11 +39,8 @@ void set_profiling(bool profiling) gc_off = false; /* end heap scan */ - /* Step 2 - Update XTs in code heap */ + /* Update XTs in code heap */ iterate_code_heap(relocate_code_block); - - /* Step 3 - flush instruction cache */ - flush_icache(code_heap.segment->start,code_heap.segment->size); } DEFINE_PRIMITIVE(profiling) diff --git a/vm/quotations.c b/vm/quotations.c index fb209c345d..e35f9dc3dd 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -236,7 +236,7 @@ void jit_compile(CELL quot) untag_object(words), untag_object(literals)); - iterate_code_heap_step(compiled,finalize_code_block); + iterate_code_heap_step(compiled,relocate_code_block); set_quot_xt(untag_object(quot),compiled); diff --git a/vm/types.c b/vm/types.c index 588e0f1ad6..3e97af8ba3 100755 --- a/vm/types.c +++ b/vm/types.c @@ -234,6 +234,42 @@ DEFINE_PRIMITIVE(array_to_vector) dpush(tag_object(vector)); } +F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) +{ + REGISTER_ROOT(elt); + + if(*result_count == array_capacity(result)) + { + result = reallot_array(result, + *result_count * 2,F); + } + + UNREGISTER_ROOT(elt); + set_array_nth(result,*result_count,elt); + *result_count = *result_count + 1; + + return result; +} + +F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) +{ + REGISTER_UNTAGGED(elts); + + CELL elts_size = array_capacity(elts); + CELL new_size = *result_count + elts_size; + + if(new_size >= array_capacity(result)) + result = reallot_array(result,new_size * 2,F); + + UNREGISTER_UNTAGGED(elts); + + memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS); + + *result_count += elts_size; + + return result; +} + /* untagged */ F_STRING* allot_string_internal(CELL capacity) { diff --git a/vm/types.h b/vm/types.h index 684f1837bd..38be4b8902 100755 --- a/vm/types.h +++ b/vm/types.h @@ -201,44 +201,12 @@ DECLARE_PRIMITIVE(wrapper); CELL result##_count = 0; \ CELL result = tag_object(allot_array(ARRAY_TYPE,100,F)) -INLINE F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) -{ - REGISTER_ROOT(elt); - - if(*result_count == array_capacity(result)) - { - result = reallot_array(result, - *result_count * 2,F); - } - - UNREGISTER_ROOT(elt); - set_array_nth(result,*result_count,elt); - *result_count = *result_count + 1; - - return result; -} +F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count); #define GROWABLE_ADD(result,elt) \ result = tag_object(growable_add(untag_object(result),elt,&result##_count)) -INLINE F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) -{ - REGISTER_UNTAGGED(elts); - - CELL elts_size = array_capacity(elts); - CELL new_size = *result_count + elts_size; - - if(new_size >= array_capacity(result)) - result = reallot_array(result,new_size * 2,F); - - UNREGISTER_UNTAGGED(elts); - - memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS); - - *result_count += elts_size; - - return result; -} +F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count); #define GROWABLE_APPEND(result,elts) \ result = tag_object(growable_append(untag_object(result),elts,&result##_count)) From c9a7138b76cac7f6a0de15ffcc683894a11480f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 17:17:39 -0500 Subject: [PATCH 28/82] Remove unused symbols --- core/bootstrap/image/image.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 5d74f5d9c6..6ea7ebb107 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -67,11 +67,9 @@ SYMBOL: jit-word-primitive-jump SYMBOL: jit-word-primitive-call SYMBOL: jit-word-jump SYMBOL: jit-word-call -SYMBOL: jit-push-wrapper SYMBOL: jit-push-literal SYMBOL: jit-if-word SYMBOL: jit-if-jump -SYMBOL: jit-if-call SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch SYMBOL: jit-epilog @@ -88,11 +86,9 @@ SYMBOL: jit-return { jit-word-primitive-call 26 } { jit-word-jump 27 } { jit-word-call 28 } - { jit-push-wrapper 29 } { jit-push-literal 30 } { jit-if-word 31 } { jit-if-jump 32 } - { jit-if-call 33 } { jit-dispatch-word 34 } { jit-dispatch 35 } { jit-epilog 36 } From 1b9e04fdc5d01ae0ff87fef59e8421f3bd202cd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 17:28:34 -0500 Subject: [PATCH 29/82] Deferred words are now compound words --- core/bootstrap/image/image.factor | 2 -- core/bootstrap/primitives.factor | 2 +- core/debugger/debugger-docs.factor | 3 --- core/debugger/debugger.factor | 11 +++++------ core/inference/backend/backend.factor | 3 --- core/words/words-docs.factor | 10 +++++----- core/words/words.factor | 24 +++++++++++++++++++----- extra/cocoa/messages/messages.factor | 2 +- extra/locals/locals.factor | 8 ++++---- vm/cpu-arm.h | 1 - vm/cpu-x86.S | 4 ---- vm/cpu-x86.h | 1 - vm/errors.c | 7 ------- vm/errors.h | 5 +---- vm/image.c | 2 +- vm/run.c | 7 ------- vm/types.c | 2 +- 17 files changed, 38 insertions(+), 56 deletions(-) mode change 100644 => 100755 core/debugger/debugger-docs.factor mode change 100644 => 100755 extra/cocoa/messages/messages.factor mode change 100644 => 100755 extra/locals/locals.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 6ea7ebb107..7748c7f418 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -374,11 +374,9 @@ M: curry ' jit-word-primitive-call jit-word-jump jit-word-call - jit-push-wrapper jit-push-literal jit-if-word jit-if-jump - jit-if-call jit-dispatch-word jit-dispatch jit-epilog diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 0142d2f9a1..28bb3637c0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -476,7 +476,7 @@ builtins get num-tags get tail f union-class define-class { "float<=" "math.private" } { "float>" "math.private" } { "float>=" "math.private" } - { "" "words" } + { "" "words.private" } { "word-xt" "words" } { "drop" "kernel" } { "2drop" "kernel" } diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor old mode 100644 new mode 100755 index d5c7ecfeb1..b754856ee4 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -98,9 +98,6 @@ HELP: expired-error. HELP: io-error. { $error-description "Thrown by the C streams I/O primitives if an I/O error occurs." } ; -HELP: undefined-word-error. -{ $error-description "Thrown if an attempt is made to call a word which was defined by " { $link POSTPONE: DEFER: } "." } ; - HELP: type-check-error. { $error-description "Thrown by various primitives if one of the inputs does not have the expected type. Generic words throw " { $link no-method } " and " { $link no-math-method } " errors in such cases instead." } ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index be3393fbc2..a085eea0cb 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -92,9 +92,6 @@ TUPLE: assert got expect ; : expired-error. ( obj -- ) "Object did not survive image save/load: " write third . ; -: undefined-word-error. ( obj -- ) - "Undefined word: " write third . ; - : io-error. ( error -- ) "I/O error: " write third print ; @@ -150,14 +147,14 @@ PREDICATE: array kernel-error ( obj -- ? ) { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } - { [ t ] [ second 0 16 between? ] } + { [ t ] [ second 0 15 between? ] } } cond ; : kernel-errors second { { 0 [ expired-error. ] } { 1 [ io-error. ] } - { 2 [ undefined-word-error. ] } + { 2 [ primitive-error. ] } { 3 [ type-check-error. ] } { 4 [ divide-by-zero-error. ] } { 5 [ signal-error. ] } @@ -171,7 +168,6 @@ PREDICATE: array kernel-error ( obj -- ? ) { 13 [ retainstack-underflow. ] } { 14 [ retainstack-overflow. ] } { 15 [ memory-error. ] } - { 16 [ primitive-error. ] } } ; inline M: kernel-error error. dup kernel-errors case ; @@ -228,3 +224,6 @@ M: redefine-error error. M: forward-error error. "Forward reference to " write forward-error-word . ; + +M: undefined summary + drop "Calling a deferred word before it has been defined" ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index e5f282a8d1..f2f153e0bd 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -465,9 +465,6 @@ M: compound apply-object [ declared-infer ] [ apply-word ] if ] if-inline ; -M: undefined apply-object - drop "Undefined word" time-bomb ; - : with-infer ( quot -- effect dataflow ) [ [ diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 91e5bef1f8..98ac00aeb7 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -50,8 +50,8 @@ ARTICLE: "deferred" "Deferred words and mutual recursion" "Words cannot be referenced before they are defined; that is, source files must order definitions in a strictly bottom-up fashion. This is done to simplify the implementation, facilitate better parse-time checking and remove some odd corner cases; it also encourages better coding style. Sometimes this restriction gets in the way, for example when defining mutually-recursive words; one way to get around this limitation is to make a forward definition." { $subsection POSTPONE: DEFER: } "The class of forward word definitions:" -{ $subsection undefined } -{ $subsection undefined? } ; +{ $subsection deferred } +{ $subsection deferred? } ; ARTICLE: "declarations" "Declarations" "Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word." @@ -197,10 +197,10 @@ HELP: set-word-def ( obj word -- ) $low-level-note { $side-effects "word" } ; -HELP: undefined -{ $class-description "The class of undefined words created by " { $link POSTPONE: DEFER: } "." } ; +HELP: deferred +{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; -{ undefined POSTPONE: DEFER: } related-words +{ deferred POSTPONE: DEFER: } related-words HELP: compound { $description "The class of compound words created by " { $link POSTPONE: : } "." } ; diff --git a/core/words/words.factor b/core/words/words.factor index 972262675f..3fba06b816 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -19,15 +19,23 @@ M: word <=> M: word definition drop f ; -PREDICATE: word undefined ( obj -- ? ) word-def not ; -M: undefined definer drop \ DEFER: f ; - PREDICATE: word compound ( obj -- ? ) word-def quotation? ; M: compound definer drop \ : \ ; ; M: compound definition word-def ; +TUPLE: undefined word ; + +: undefined ( word -- * ) \ undefined construct-boa throw ; + +PREDICATE: compound deferred ( obj -- ? ) + dup [ undefined ] curry swap word-def sequence= ; + +M: deferred definer drop \ DEFER: f ; + +M: deferred definition drop f ; + PREDICATE: compound symbol ( obj -- ? ) dup 1array swap word-def sequence= ; M: symbol definer drop \ SYMBOL: f ; @@ -102,6 +110,9 @@ PRIVATE> : define-compound ( word def -- ) [ ] like define ; +: undefine ( word -- ) + dup [ undefined ] curry define-compound ; + : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop define-compound ; @@ -133,8 +144,11 @@ PRIVATE> : reset-generic ( word -- ) dup reset-word { "methods" "combination" } reset-props ; +: ( name -- word ) + f dup undefine ; + : gensym ( -- word ) - "G:" \ gensym counter number>string append f ; + "G:" \ gensym counter number>string append ; : define-temp ( quot -- word ) gensym dup rot define-compound ; @@ -151,7 +165,7 @@ TUPLE: check-create name vocab ; : create ( name vocab -- word ) check-create 2dup lookup - dup [ 2nip ] [ drop dup reveal ] if ; + dup [ 2nip ] [ drop dup reveal dup undefine ] if ; : constructor-word ( name vocab -- word ) >r "<" swap ">" 3append r> create ; diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor old mode 100644 new mode 100755 index 54ddbaa0cf..b0a4253b1b --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -14,7 +14,7 @@ IN: cocoa.messages [ % "_" % unparse % ] "" make ; : sender-stub ( method function -- word ) - [ sender-stub-name f dup ] 2keep + [ sender-stub-name dup ] 2keep over first large-struct? [ "_stret" append ] when make-sender define-compound dup compile ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor old mode 100644 new mode 100755 index 688507be78..3582f92a5f --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -27,22 +27,22 @@ PREDICATE: word local "local?" word-prop ; : ( name -- word ) #! Create a local variable identifier - f dup t "local?" set-word-prop ; + dup t "local?" set-word-prop ; PREDICATE: word local-word "local-word?" word-prop ; : ( name -- word ) - f dup t "local-word?" set-word-prop ; + dup t "local-word?" set-word-prop ; PREDICATE: word local-reader "local-reader?" word-prop ; : ( name -- word ) - f dup t "local-reader?" set-word-prop ; + dup t "local-reader?" set-word-prop ; PREDICATE: word local-writer "local-writer?" word-prop ; : ( reader -- word ) - dup word-name "!" append f + dup word-name "!" append [ t "local-writer?" set-word-prop ] keep [ "local-writer" set-word-prop ] 2keep [ swap "local-reader" set-word-prop ] keep ; diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h index c134389969..e6ea0a1158 100755 --- a/vm/cpu-arm.h +++ b/vm/cpu-arm.h @@ -8,7 +8,6 @@ register CELL rs asm("r6"); #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) void c_to_factor(CELL quot); -void undefined(CELL word); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); void throw_impl(CELL quot, F_STACK_FRAME *rewind); void lazy_jit_compile(CELL quot); diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index eef540907e..5c0a105a55 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -14,10 +14,6 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): POP_NONVOLATILE ret -DEF(F_FASTCALL void,undefined,(CELL word)): - mov STACK_REG,ARG1 /* Pass callstack pointer */ - jmp MANGLE(undefined_error) /* This throws an error */ - DEF(F_FASTCALL void,primitive_call,(void)): mov (DS_REG),ARG0 /* Load quotation from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index e2c474808e..3b08479e4b 100755 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -4,7 +4,6 @@ INLINE void flush_icache(CELL start, CELL len) {} F_FASTCALL void c_to_factor(CELL quot); F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); -F_FASTCALL void undefined(CELL word); F_FASTCALL void lazy_jit_compile(CELL quot); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); diff --git a/vm/errors.c b/vm/errors.c index e82942af55..966fbe353d 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -75,13 +75,6 @@ void not_implemented_error(void) general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); } -/* This function is called from the undefined function in cpu_*.S */ -F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) -{ - stack_chain->callstack_top = callstack_top; - general_error(ERROR_UNDEFINED_WORD,word,F,NULL); -} - /* Test if 'fault' is in the guard page at the top or bottom (depending on offset being 0 or -1) of area+area_size */ bool in_page(CELL fault, CELL area, CELL area_size, int offset) diff --git a/vm/errors.h b/vm/errors.h index 14e755a095..5fe5b08e0d 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -3,7 +3,7 @@ typedef enum { ERROR_EXPIRED = 0, ERROR_IO, - ERROR_UNDEFINED_WORD, + ERROR_NOT_IMPLEMENTED, ERROR_TYPE, ERROR_DIVIDE_BY_ZERO, ERROR_SIGNAL, @@ -17,7 +17,6 @@ typedef enum ERROR_RS_UNDERFLOW, ERROR_RS_OVERFLOW, ERROR_MEMORY, - ERROR_NOT_IMPLEMENTED, } F_ERRORTYPE; void fatal_error(char* msg, CELL tagged); @@ -32,8 +31,6 @@ void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); void not_implemented_error(void); -F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); - DECLARE_PRIMITIVE(throw); DECLARE_PRIMITIVE(call_clear); diff --git a/vm/image.c b/vm/image.c index fab37d6303..251136e16b 100755 --- a/vm/image.c +++ b/vm/image.c @@ -189,7 +189,7 @@ void fixup_word(F_WORD *word) } else { - /* Primitive or undefined */ + /* Primitive */ default_word_xt(word); return; } diff --git a/vm/run.c b/vm/run.c index 766f399328..c5f16ac190 100755 --- a/vm/run.c +++ b/vm/run.c @@ -268,16 +268,9 @@ void default_word_xt(F_WORD *word) critical_error("default_word_xt invariant lost",0); word->xt = quot->xt; word->code = quot->code; - - //if(profiling_p()) - // word->xt = docol_profiling; - //else - // word->xt = docol; } else if(type_of(word->def) == FIXNUM_TYPE) word->xt = primitives[to_fixnum(word->def)]; - else if(word->def == F) - word->xt = undefined; else critical_error("bad word-def",tag_object(word)); } diff --git a/vm/types.c b/vm/types.c index 3e97af8ba3..aad2be8a1c 100755 --- a/vm/types.c +++ b/vm/types.c @@ -499,7 +499,7 @@ F_WORD *allot_word(CELL vocab, CELL name) word->props = F; word->counter = tag_fixnum(0); word->compiledp = F; - word->xt = undefined; + word->xt = NULL; return word; } From 93e1bdfcd7112d51d19a3a78b66a67408afc1671 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 20:02:41 -0500 Subject: [PATCH 30/82] Simplify JIT, fix tuples unit tests --- core/bootstrap/image/image.factor | 3 --- core/bootstrap/primitives.factor | 1 - core/bootstrap/stage2.factor | 2 +- core/cpu/x86/32/bootstrap.factor | 1 - core/cpu/x86/bootstrap.factor | 28 +++++-------------------- core/tuples/tuples-tests.factor | 19 +---------------- extra/tools/deploy/shaker/shaker.factor | 2 -- vm/callstack.c | 11 ++++++---- vm/data_gc.c | 22 ++++++++----------- vm/image.c | 8 ------- vm/layouts.h | 12 +---------- vm/primitives.c | 1 - vm/quotations.c | 22 ------------------- vm/quotations.h | 1 - vm/run.h | 2 +- 15 files changed, 25 insertions(+), 110 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7748c7f418..c150a85eb1 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -61,7 +61,6 @@ SYMBOL: bootstrap-boot-quot ! JIT parameters SYMBOL: jit-code-format -SYMBOL: jit-setup SYMBOL: jit-prolog SYMBOL: jit-word-primitive-jump SYMBOL: jit-word-primitive-call @@ -80,7 +79,6 @@ SYMBOL: jit-return { bootstrap-boot-quot 20 } { bootstrap-global 21 } { jit-code-format 22 } - { jit-setup 23 } { jit-prolog 24 } { jit-word-primitive-jump 25 } { jit-word-primitive-call 26 } @@ -368,7 +366,6 @@ M: curry ' \ dispatch jit-dispatch-word set { jit-code-format - jit-setup jit-prolog jit-word-primitive-jump jit-word-primitive-call diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 28bb3637c0..6b95edd677 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -602,7 +602,6 @@ builtins get num-tags get tail f union-class define-class { "innermost-frame-scan" "kernel.private" } { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } - { "strip-compiled-quotations" "quotations" } { "(os-envs)" "system" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2e4ad9193a..9e14985551 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -66,7 +66,7 @@ IN: bootstrap.stage2 ] set-boot-quot : count-words all-words swap subset length pprint ; - + [ compiled? ] count-words " compiled words" print [ symbol? ] count-words " symbol words" print [ ] count-words " words total" print diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 88a7028929..be78b2ce6c 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -10,7 +10,6 @@ IN: bootstrap.x86 : arg1 EDX ; : stack-reg ESP ; : ds-reg ESI ; -: scan-reg EBX ; : fixnum>slot@ arg0 1 SAR ; "resource:core/cpu/x86/bootstrap.factor" run-file diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 7fe10b7ec3..be5275811c 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -8,30 +8,18 @@ big-endian off 1 jit-code-format set -: stack-frame-size 8 bootstrap-cells ; - -: scan-save stack-reg 3 bootstrap-cells [+] ; +: stack-frame-size 4 bootstrap-cells ; [ arg0 0 [] MOV ! load quotation arg1 arg0 quot-xt@ [+] MOV ! load XT - arg0 arg0 quot-array@ [+] MOV ! load array - scan-reg arg0 scan@ [+] LEA ! initialize scan pointer -] rc-absolute-cell rt-literal 2 jit-setup jit-define - -[ stack-frame-size PUSH ! save stack frame size arg1 PUSH ! save XT - arg0 PUSH ! save array - scan-reg PUSH ! initial scan - stack-reg 3 bootstrap-cells SUB ! reserved -] f f f jit-prolog jit-define - -: advance-scan scan-reg bootstrap-cell ADD ; + arg1 PUSH ! alignment +] rc-absolute-cell rt-literal 2 jit-prolog jit-define [ arg0 0 [] MOV ! load literal - advance-scan ds-reg bootstrap-cell ADD ! increment datastack pointer ds-reg [] arg0 MOV ! store literal on datastack ] rc-absolute-cell rt-literal 2 jit-push-literal jit-define @@ -42,23 +30,17 @@ big-endian off ] rc-relative rt-primitive 3 jit-word-primitive-jump jit-define [ - advance-scan arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2 - scan-save scan-reg MOV ! save scan pointer (CALL) drop ! go - scan-reg scan-save MOV ! restore scan pointer -] rc-relative rt-primitive 12 jit-word-primitive-call jit-define +] rc-relative rt-primitive 5 jit-word-primitive-call jit-define [ (JMP) drop ] rc-relative rt-xt 1 jit-word-jump jit-define [ - advance-scan - scan-save scan-reg MOV ! save scan pointer (CALL) drop - scan-reg scan-save MOV ! restore scan pointer -] rc-relative rt-xt 8 jit-word-call jit-define +] rc-relative rt-xt 1 jit-word-call jit-define [ arg1 0 MOV ! load addr of true quotation diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index e21d21813a..bdb8b61299 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -78,8 +78,6 @@ M: circle area circle-radius sq pi * ; [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test -[ ] [ "IN: temporary SYMBOL: #x TUPLE: #x ;" eval ] unit-test - ! Hashcode breakage TUPLE: empty ; @@ -216,25 +214,10 @@ SYMBOL: not-a-tuple-class [ not-a-tuple-class construct-boa ] unit-test-fails [ not-a-tuple-class construct-empty ] unit-test-fails -TUPLE: erg's-reshape-problem a b c ; +TUPLE: erg's-reshape-problem a b c d ; C: erg's-reshape-problem -[ ] [ - ! hasn't been recompiled yet, so - ! we just created a tuple using an obsolete layout - "IN: temporary USE: namespaces TUPLE: erg's-reshape-problem a b c d ; 1 2 3 \"a\" set" eval -] unit-test - -[ 1 2 ] [ - ! that's ok, but... this shouldn't fail: - "IN: temporary TUPLE: erg's-reshape-problem a b d c ;" eval - - "a" get - { erg's-reshape-problem-a erg's-reshape-problem-b } - get-slots -] unit-test - ! We want to make sure constructors are recompiled when ! tuples are reshaped : cons-test-1 \ erg's-reshape-problem construct-empty ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 7b6d3fdbb5..9c2a9ce4e1 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -90,8 +90,6 @@ IN: tools.deploy.shaker { } set-retainstack V{ } set-namestack V{ } set-catchstack - "Stripping compiled quotations" show - strip-compiled-quotations "Saving final image" show [ save-image-and-exit ] call-clear ; diff --git a/vm/callstack.c b/vm/callstack.c index a53578f78c..8c11b15aae 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -123,8 +123,9 @@ F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) CELL frame_scan(F_STACK_FRAME *frame) { + //XXX if(frame_type(frame) == QUOTATION_TYPE) - return tag_fixnum(UNAREF(UNTAG(frame->array),frame->scan)); + return tag_fixnum(0); //UNAREF(UNTAG(frame->array),frame->scan)); else return F; } @@ -213,11 +214,13 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot) F_STACK_FRAME *inner = innermost_stack_frame(callstack); type_check(QUOTATION_TYPE,frame_executing(inner)); - CELL scan = inner->scan - inner->array; + //XXX + + //CELL scan = inner->scan - inner->array; CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt; - inner->array = quot->array; - inner->scan = quot->array + scan; + //inner->array = quot->array; + //inner->scan = quot->array + scan; inner->xt = quot->xt; diff --git a/vm/data_gc.c b/vm/data_gc.c index ab9bb509a0..876b30084a 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -380,24 +380,19 @@ void collect_stack(F_SEGMENT *region, CELL top) void collect_stack_frame(F_STACK_FRAME *frame) { - if(frame_type(frame) == QUOTATION_TYPE) - { - CELL scan = frame->scan - frame->array; - copy_handle(&frame->array); - frame->scan = scan + frame->array; - } - - if(collecting_code) - recursive_mark(compiled_to_block(frame_code(frame))); + recursive_mark(compiled_to_block(frame_code(frame))); } /* The base parameter allows us to adjust for a heap-allocated callstack snapshot */ void collect_callstack(F_CONTEXT *stacks) { - CELL top = (CELL)stacks->callstack_top; - CELL bottom = (CELL)stacks->callstack_bottom; - iterate_callstack(top,bottom,collect_stack_frame); + if(collecting_code) + { + CELL top = (CELL)stacks->callstack_top; + CELL bottom = (CELL)stacks->callstack_bottom; + iterate_callstack(top,bottom,collect_stack_frame); + } } void collect_gc_locals(void) @@ -541,7 +536,8 @@ CELL binary_payload_start(CELL pointer) void collect_callstack_object(F_CALLSTACK *callstack) { - iterate_callstack_object(callstack,collect_stack_frame); + if(collecting_code) + iterate_callstack_object(callstack,collect_stack_frame); } CELL collect_next(CELL scan) diff --git a/vm/image.c b/vm/image.c index 251136e16b..8fc99d7cd9 100755 --- a/vm/image.c +++ b/vm/image.c @@ -218,14 +218,6 @@ void fixup_alien(F_ALIEN *d) void fixup_stack_frame(F_STACK_FRAME *frame) { code_fixup((CELL)&frame->xt); - - if(frame_type(frame) == QUOTATION_TYPE) - { - CELL scan = frame->scan - frame->array; - data_fixup(&frame->array); - frame->scan = scan + frame->array; - } - code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame)); } diff --git a/vm/layouts.h b/vm/layouts.h index b53f6a3eef..41574ff2f4 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -239,7 +239,7 @@ typedef struct { /* tagged byte array holding a C string */ CELL path; /* OS-specific handle */ - void* dll; + void *dll; } F_DLL; typedef struct { @@ -258,17 +258,7 @@ typedef struct { typedef struct { - /* In compiled quotation frames, position within the array. - In compiled word frames, unused. */ - CELL scan; - - /* In compiled quotation frames, the quot->array slot. - In compiled word frames, unused. */ - CELL array; - - /* In all compiled frames, the XT on entry. */ XT xt; - /* Frame size in bytes */ CELL size; } F_STACK_FRAME; diff --git a/vm/primitives.c b/vm/primitives.c index a70f7e4d95..9bc1323eae 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -192,6 +192,5 @@ void *primitives[] = { primitive_innermost_stack_frame_scan, primitive_set_innermost_stack_frame_quot, primitive_call_clear, - primitive_strip_compiled_quotations, primitive_os_envs, }; diff --git a/vm/quotations.c b/vm/quotations.c index e35f9dc3dd..791802bd0d 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -116,8 +116,6 @@ void jit_compile(CELL quot) bool stack_frame = jit_stack_frame_p(untag_object(array)); - EMIT(JIT_SETUP,0); - if(stack_frame) EMIT(JIT_PROLOG,0); @@ -316,23 +314,3 @@ DEFINE_PRIMITIVE(quotation_xt) F_QUOTATION *quot = untag_quotation(dpeek()); drepl(allot_cell((CELL)quot->xt)); } - -DEFINE_PRIMITIVE(strip_compiled_quotations) -{ - data_gc(); - begin_scan(); - - CELL obj; - while((obj = next_object()) != F) - { - if(type_of(obj) == QUOTATION_TYPE) - { - F_QUOTATION *quot = untag_object(obj); - quot->compiledp = F; - quot->xt = lazy_jit_compile; - } - } - - /* end scan */ - gc_off = false; -} diff --git a/vm/quotations.h b/vm/quotations.h index ebbacb8f45..c4c22e2153 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -6,4 +6,3 @@ DECLARE_PRIMITIVE(curry); DECLARE_PRIMITIVE(array_to_quotation); DECLARE_PRIMITIVE(quotation_xt); DECLARE_PRIMITIVE(uncurry); -DECLARE_PRIMITIVE(strip_compiled_quotations); diff --git a/vm/run.h b/vm/run.h index e4d6926771..62d6cca23e 100755 --- a/vm/run.h +++ b/vm/run.h @@ -34,7 +34,7 @@ typedef enum { /* Used by the JIT compiler */ JIT_CODE_FORMAT = 22, - JIT_SETUP, + UNUSED_0, JIT_PROLOG, JIT_WORD_PRIMITIVE_JUMP, JIT_WORD_PRIMITIVE_CALL, From 9de32c7b2d755e6683c6f51f8c54dd9096c8e3eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 20:20:49 -0500 Subject: [PATCH 31/82] Remove temporary hack now that new JIT works --- core/definitions/definitions.factor | 4 ---- core/generic/generic-docs.factor | 6 ------ core/generic/generic.factor | 12 +++--------- 3 files changed, 3 insertions(+), 19 deletions(-) mode change 100644 => 100755 core/generic/generic-docs.factor diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 940de86d54..9612b97502 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -45,7 +45,6 @@ M: object redefined* drop ; dup unxref crossref get delete-at ; SYMBOL: changed-words -SYMBOL: changed-generics SYMBOL: old-definitions SYMBOL: new-definitions @@ -79,18 +78,15 @@ TUPLE: forward-error word ; [ drop f ] if ; SYMBOL: recompile-hook -SYMBOL: make-generic-hook : ( -- pair ) { H{ } H{ } } [ clone ] map ; : with-compilation-unit ( quot -- new-defs ) [ H{ } clone changed-words set - H{ } clone changed-generics set new-definitions set old-definitions set [ - changed-generics get keys make-generic-hook get call changed-words get keys recompile-hook get call ] [ ] cleanup ] with-scope ; inline diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor old mode 100644 new mode 100755 index 53f1a9ea3e..9dfc40a869 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -44,7 +44,6 @@ $nl { $subsection implementors } "Low-level words which rebuilds the generic word after methods are added or removed, or the method combination is changed:" { $subsection make-generic } -{ $subsection ?make-generic } "A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":" { $subsection method-spec } ; @@ -108,11 +107,6 @@ HELP: make-generic { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." } $low-level-note ; -HELP: ?make-generic -{ $values { "word" generic } } -{ $description "Regenerates the definition of a generic word, unless bootstrap is in progress, in which case nothing is done. This avoids regenerating generic words multiple times during bootstrap as methods are defined. Instead, all generic words are built once at the end of the process, resulting in a performance improvement." } -$low-level-note ; - HELP: init-methods { $values { "word" word } } { $description "Prepare to define a generic word." } ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 29b357be18..9e3520dc27 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -28,12 +28,6 @@ M: object perform-combination dup "combination" word-prop perform-combination define-compound ; -[ [ make-generic ] each ] make-generic-hook set-global - -: ?make-generic ( word -- ) - dup compound? [ dup [ ] define-compound ] unless - dup changed-generics get set-at ; - : init-methods ( word -- ) dup "methods" word-prop H{ } assoc-like @@ -41,7 +35,7 @@ M: object perform-combination : define-generic ( word combination -- ) dupd "combination" set-word-prop - dup init-methods ?make-generic ; + dup init-methods make-generic ; TUPLE: method loc def ; @@ -77,7 +71,7 @@ TUPLE: check-method class generic ; ] unless ; : with-methods ( word quot -- ) - swap [ "methods" word-prop swap call ] keep ?make-generic ; + swap [ "methods" word-prop swap call ] keep make-generic ; inline : define-method ( method class generic -- ) @@ -114,4 +108,4 @@ M: class forget ( class -- ) forget-word ; M: class update-methods ( class -- ) - class-usages implementors* [ ?make-generic ] each ; + class-usages implementors* [ make-generic ] each ; From f624726e8e39678097f87b42ee13eb4c2bbc8084 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 20:21:18 -0500 Subject: [PATCH 32/82] Fix bootstrap --- core/bootstrap/primitives.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6b95edd677..d379a89142 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -22,7 +22,6 @@ crossref off H{ } clone dictionary set H{ } clone changed-words set -H{ } clone changed-generics set [ drop ] recompile-hook set call @@ -608,6 +607,3 @@ dup length [ >r first2 r> make-primitive ] 2each ! Bump build number "build" "kernel" create build 1+ 1quotation define-compound - -! Make generics -changed-generics get keys [ make-generic ] each From 2a24567546339ebd0dd4b121e5278c9112766f59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 20:21:46 -0500 Subject: [PATCH 33/82] Work in progress --- core/bootstrap/compiler/compiler.factor | 29 ++++++++----------- core/compiler/compiler.factor | 9 ++++-- core/generator/generator.factor | 5 ++-- core/inference/known-words/known-words.factor | 2 +- 4 files changed, 22 insertions(+), 23 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index a0d767a387..cc8a78509b 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -13,15 +13,12 @@ IN: bootstrap.compiler 0 profiler-prologue set-global ] when -: compile* [ compiled? not ] subset compile ; - -! Compile a set of words ahead of our general -! compile-all. This set of words was determined -! semi-empirically using the profiler. It improves -! bootstrap time significantly, because frequenly -! called words which are also quick to compile -! are replaced by compiled definitions as soon as -! possible. +! Compile a set of words ahead of the full compile. +! This set of words was determined semi-empirically +! using the profiler. It improves bootstrap time +! significantly, because frequenly called words +! which are also quick to compile are replaced by +! compiled definitions as soon as possible. { roll -roll declare not @@ -39,24 +36,22 @@ IN: bootstrap.compiler find-pair-next namestack* bitand bitor bitxor bitnot -} compile* +} compile { + 1+ 1- 2/ < <= > >= shift min -} compile* +} compile { new nth push pop peek hashcode* = get set -} compile* +} compile { . lines -} compile* +} compile { malloc free memcpy -} compile* +} compile -[ compile ] recompile-hook set-global - -FORGET: compile* +[ recompile ] recompile-hook set-global diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index fb3ec90a74..ed21e0a352 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -44,7 +44,7 @@ SYMBOL: compiler-hook dup assoc-empty? [ drop ] [ dup delete-any (compile) compile-loop ] if ; -: compile ( words -- ) +: recompile ( words -- ) [ H{ } clone compile-queue set H{ } clone compiled set @@ -53,13 +53,16 @@ SYMBOL: compiler-hook compiled get >alist modify-code-heap ] with-scope ; inline +: compile ( words -- ) + [ compiled? not ] subset recompile ; + : compile-quot ( quot -- word ) H{ } clone changed-words [ - define-temp dup 1array compile + define-temp dup 1array recompile ] with-variable ; : compile-call ( quot -- ) compile-quot execute ; : compile-all ( -- ) - all-words compile ; + all-words recompile ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index a1a9c9be81..e085087da0 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -21,7 +21,8 @@ SYMBOL: compiled : queue-compile ( word -- ) { { [ dup compiled get key? ] [ drop ] } - { [ dup compound? not ] [ f swap compiled get set-at ] } + { [ dup primitive? ] [ drop ] } + { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; @@ -49,7 +50,7 @@ t compiled-stack-traces? set-global pick begin-compiling [ roll compiling-word set pick compiling-label set - init-generator + compiling-word get init-generator call literal-table get >array word-table get >array diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 97a426bb56..d539e09e7d 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -10,7 +10,7 @@ namespaces namespaces.private parser prettyprint quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private tuples tuples.private vectors vectors.private -words assocs ; +words words.private assocs ; ! Shuffle words : infer-shuffle-inputs ( shuffle node -- ) From c5d91d12df560b32f550f3b8da1ba8cdf01ee4fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 20:40:46 -0500 Subject: [PATCH 34/82] Fix implementation of deferred words --- core/bootstrap/image/image.factor | 30 ++++++++++++++++++------------ core/words/words-tests.factor | 13 +++++++++---- core/words/words.factor | 18 +++++------------- vm/factor.c | 2 ++ vm/run.h | 8 ++------ vm/types.c | 4 ++-- 6 files changed, 38 insertions(+), 37 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index c150a85eb1..0052dd34f2 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -74,23 +74,27 @@ SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return +! Default definition for undefined words +SYMBOL: undefined-quot + : userenv-offset ( symbol -- n ) { { bootstrap-boot-quot 20 } { bootstrap-global 21 } { jit-code-format 22 } - { jit-prolog 24 } - { jit-word-primitive-jump 25 } - { jit-word-primitive-call 26 } - { jit-word-jump 27 } - { jit-word-call 28 } - { jit-push-literal 30 } - { jit-if-word 31 } - { jit-if-jump 32 } - { jit-dispatch-word 34 } - { jit-dispatch 35 } - { jit-epilog 36 } - { jit-return 37 } + { jit-prolog 23 } + { jit-word-primitive-jump 24 } + { jit-word-primitive-call 25 } + { jit-word-jump 26 } + { jit-word-call 27 } + { jit-push-literal 28 } + { jit-if-word 29 } + { jit-if-jump 30 } + { jit-dispatch-word 31 } + { jit-dispatch 32 } + { jit-epilog 33 } + { jit-return 34 } + { undefined-quot 37 } } at header-size + ; : emit ( cell -- ) image get push ; @@ -364,6 +368,7 @@ M: curry ' : emit-jit-data ( -- ) \ if jit-if-word set \ dispatch jit-dispatch-word set + [ undefined ] undefined-quot set { jit-code-format jit-prolog @@ -378,6 +383,7 @@ M: curry ' jit-dispatch jit-epilog jit-return + undefined-quot } [ emit-userenv ] each ; : fixup-header ( -- ) diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 82277be78c..8e05044223 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,6 +1,6 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations -vocabs continuations ; +vocabs continuations tuples ; IN: temporary [ 4 ] [ @@ -34,7 +34,7 @@ DEFER: plist-test [ [ t ] [ \ array? "array?" "arrays" lookup = ] unit-test - "test-scope" "scratchpad" create drop + [ ] [ "test-scope" "scratchpad" create drop ] unit-test ] with-scope [ "test-scope" ] [ @@ -52,7 +52,7 @@ DEFER: plist-test [ t ] [ \ colon-def compound? ] unit-test SYMBOL: a-symbol -[ f ] [ \ a-symbol compound? ] unit-test +[ t ] [ \ a-symbol compound? ] unit-test [ t ] [ \ a-symbol symbol? ] unit-test ! See if redefining a generic as a colon def clears some @@ -126,7 +126,7 @@ M: array freakish ; [ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x -[ t ] [ [ x ] catch third \ x eq? ] unit-test +[ t ] [ [ x ] catch undefined? ] unit-test [ ] [ "no-loc" "temporary" create drop ] unit-test [ f ] [ "no-loc" "temporary" lookup where ] unit-test @@ -156,3 +156,8 @@ SYMBOL: quot-uses-b ] unit-test [ { + } ] [ \ quot-uses-b uses ] unit-test + +[ t ] [ + [ "IN: temporary : undef-test ; << undef-test >>" eval ] catch + [ undefined? ] is? +] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 3fba06b816..baec10a821 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -25,15 +25,13 @@ M: compound definer drop \ : \ ; ; M: compound definition word-def ; -TUPLE: undefined word ; +TUPLE: undefined ; -: undefined ( word -- * ) \ undefined construct-boa throw ; +: undefined ( -- * ) \ undefined construct-empty throw ; PREDICATE: compound deferred ( obj -- ? ) - dup [ undefined ] curry swap word-def sequence= ; - + word-def [ undefined ] = ; M: deferred definer drop \ DEFER: f ; - M: deferred definition drop f ; PREDICATE: compound symbol ( obj -- ? ) @@ -110,9 +108,6 @@ PRIVATE> : define-compound ( word def -- ) [ ] like define ; -: undefine ( word -- ) - dup [ undefined ] curry define-compound ; - : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop define-compound ; @@ -144,11 +139,8 @@ PRIVATE> : reset-generic ( word -- ) dup reset-word { "methods" "combination" } reset-props ; -: ( name -- word ) - f dup undefine ; - : gensym ( -- word ) - "G:" \ gensym counter number>string append ; + "G:" \ gensym counter number>string append f ; : define-temp ( quot -- word ) gensym dup rot define-compound ; @@ -165,7 +157,7 @@ TUPLE: check-create name vocab ; : create ( name vocab -- word ) check-create 2dup lookup - dup [ 2nip ] [ drop dup reveal dup undefine ] if ; + dup [ 2nip ] [ drop dup reveal ] if ; : constructor-word ( name vocab -- word ) >r "<" swap ">" 3append r> create ; diff --git a/vm/factor.c b/vm/factor.c index 864293e2f3..7b74ef6532 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -35,6 +35,8 @@ void do_stage1_init(void) fprintf(stderr,"*** Starting stage 2 early init...\n"); fflush(stderr); + jit_compile(userenv[UNDEFINED_ENV]); + begin_scan(); CELL obj; diff --git a/vm/run.h b/vm/run.h index 62d6cca23e..f7668483ba 100755 --- a/vm/run.h +++ b/vm/run.h @@ -34,26 +34,22 @@ typedef enum { /* Used by the JIT compiler */ JIT_CODE_FORMAT = 22, - UNUSED_0, JIT_PROLOG, JIT_WORD_PRIMITIVE_JUMP, JIT_WORD_PRIMITIVE_CALL, JIT_WORD_JUMP, JIT_WORD_CALL, - UNUSED_1, JIT_PUSH_LITERAL, JIT_IF_WORD, JIT_IF_JUMP, - UNUSED_2, JIT_DISPATCH_WORD, JIT_DISPATCH, JIT_EPILOG, JIT_RETURN, - /* Profiler support */ + UNDEFINED_ENV = 37, /* default quotation for undefined words */ PROFILING_ENV = 38, /* is the profiler on? */ - - STAGE2_ENV = 39 /* Have we bootstrapped? */ + STAGE2_ENV = 39 /* have we bootstrapped? */ } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV diff --git a/vm/types.c b/vm/types.c index aad2be8a1c..b5bf1a7449 100755 --- a/vm/types.c +++ b/vm/types.c @@ -495,11 +495,11 @@ F_WORD *allot_word(CELL vocab, CELL name) word->hashcode = tag_fixnum(rand()); word->vocabulary = vocab; word->name = name; - word->def = F; + word->def = userenv[UNDEFINED_ENV]; word->props = F; word->counter = tag_fixnum(0); word->compiledp = F; - word->xt = NULL; + default_word_xt(word); return word; } From 612b2bf78c5128b29f23d6b1f419a2a8eed28386 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 20:41:02 -0500 Subject: [PATCH 35/82] Removed --- extra/cocoa/messages/messages.factor | 2 +- extra/locals/locals.factor | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index b0a4253b1b..54ddbaa0cf 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -14,7 +14,7 @@ IN: cocoa.messages [ % "_" % unparse % ] "" make ; : sender-stub ( method function -- word ) - [ sender-stub-name dup ] 2keep + [ sender-stub-name f dup ] 2keep over first large-struct? [ "_stret" append ] when make-sender define-compound dup compile ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 3582f92a5f..688507be78 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -27,22 +27,22 @@ PREDICATE: word local "local?" word-prop ; : ( name -- word ) #! Create a local variable identifier - dup t "local?" set-word-prop ; + f dup t "local?" set-word-prop ; PREDICATE: word local-word "local-word?" word-prop ; : ( name -- word ) - dup t "local-word?" set-word-prop ; + f dup t "local-word?" set-word-prop ; PREDICATE: word local-reader "local-reader?" word-prop ; : ( name -- word ) - dup t "local-reader?" set-word-prop ; + f dup t "local-reader?" set-word-prop ; PREDICATE: word local-writer "local-writer?" word-prop ; : ( reader -- word ) - dup word-name "!" append + dup word-name "!" append f [ t "local-writer?" set-word-prop ] keep [ "local-writer" set-word-prop ] 2keep [ swap "local-reader" set-word-prop ] keep ; From f53fa196acd6bd702d1ca7b9384969d8e9fdec24 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 20:54:38 -0500 Subject: [PATCH 36/82] New must-infer word; \ foo must-infer asserts that foo's declared effect matches its inferred effect, put this in your unit tests --- core/inference/inference-tests.factor | 152 +++++++++--------- extra/io/launcher/launcher-tests.factor | 2 +- extra/tools/test/inference/inference.factor | 9 +- extra/ui/gadgets/editors/editors-tests.factor | 2 +- extra/ui/gadgets/gadgets-tests.factor | 16 +- .../ui/tools/workspace/workspace-tests.factor | 2 +- 6 files changed, 94 insertions(+), 89 deletions(-) diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 7dae2e44d8..9ee2953445 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -3,7 +3,7 @@ inference.dataflow kernel classes kernel.private math math.parser math.private namespaces namespaces.private parser sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions -prettyprint io inspector bootstrap.image tuples +prettyprint io inspector tuples classes.union classes.predicate debugger bootstrap.image bootstrap.image.private threads.private io.streams.string combinators.private tools.test.inference ; @@ -352,69 +352,69 @@ DEFER: bar [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails ! Test number protocol -{ 2 1 } [ bitor ] unit-test-effect -{ 2 1 } [ bitand ] unit-test-effect -{ 2 1 } [ bitxor ] unit-test-effect -{ 2 1 } [ mod ] unit-test-effect -{ 2 1 } [ /i ] unit-test-effect -{ 2 1 } [ /f ] unit-test-effect -{ 2 2 } [ /mod ] unit-test-effect -{ 2 1 } [ + ] unit-test-effect -{ 2 1 } [ - ] unit-test-effect -{ 2 1 } [ * ] unit-test-effect -{ 2 1 } [ / ] unit-test-effect -{ 2 1 } [ < ] unit-test-effect -{ 2 1 } [ <= ] unit-test-effect -{ 2 1 } [ > ] unit-test-effect -{ 2 1 } [ >= ] unit-test-effect -{ 2 1 } [ number= ] unit-test-effect +\ bitor must-infer +\ bitand must-infer +\ bitxor must-infer +\ mod must-infer +\ /i must-infer +\ /f must-infer +\ /mod must-infer +\ + must-infer +\ - must-infer +\ * must-infer +\ / must-infer +\ < must-infer +\ <= must-infer +\ > must-infer +\ >= must-infer +\ number= must-infer ! Test object protocol -{ 2 1 } [ = ] unit-test-effect -{ 1 1 } [ clone ] unit-test-effect -{ 2 1 } [ hashcode* ] unit-test-effect +\ = must-infer +\ clone must-infer +\ hashcode* must-infer ! Test sequence protocol -{ 1 1 } [ length ] unit-test-effect -{ 2 1 } [ nth ] unit-test-effect -{ 2 0 } [ set-length ] unit-test-effect -{ 3 0 } [ set-nth ] unit-test-effect -{ 2 1 } [ new ] unit-test-effect -{ 2 1 } [ new-resizable ] unit-test-effect -{ 2 1 } [ like ] unit-test-effect -{ 2 0 } [ lengthen ] unit-test-effect +\ length must-infer +\ nth must-infer +\ set-length must-infer +\ set-nth must-infer +\ new must-infer +\ new-resizable must-infer +\ like must-infer +\ lengthen must-infer ! Test assoc protocol -{ 2 2 } [ at* ] unit-test-effect -{ 3 0 } [ set-at ] unit-test-effect -{ 2 1 } [ new-assoc ] unit-test-effect -{ 2 0 } [ delete-at ] unit-test-effect -{ 1 0 } [ clear-assoc ] unit-test-effect -{ 1 1 } [ assoc-size ] unit-test-effect -{ 2 1 } [ assoc-like ] unit-test-effect -{ 2 1 } [ assoc-clone-like ] unit-test-effect -{ 1 1 } [ >alist ] unit-test-effect +\ at* must-infer +\ set-at must-infer +\ new-assoc must-infer +\ delete-at must-infer +\ clear-assoc must-infer +\ assoc-size must-infer +\ assoc-like must-infer +\ assoc-clone-like must-infer +\ >alist must-infer { 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect ! Test some random library words -{ 1 1 } [ 1quotation ] unit-test-effect -{ 1 1 } [ string>number ] unit-test-effect -{ 1 1 } [ get ] unit-test-effect +\ 1quotation must-infer +\ string>number must-infer +\ get must-infer -{ 2 0 } [ push ] unit-test-effect -{ 2 1 } [ append ] unit-test-effect -{ 1 1 } [ peek ] unit-test-effect +\ push must-infer +\ append must-infer +\ peek must-infer -{ 1 1 } [ reverse ] unit-test-effect -{ 2 1 } [ member? ] unit-test-effect -{ 2 1 } [ remove ] unit-test-effect -{ 1 1 } [ natural-sort ] unit-test-effect +\ reverse must-infer +\ member? must-infer +\ remove must-infer +\ natural-sort must-infer -{ 1 0 } [ forget ] unit-test-effect -{ 4 0 } [ define-class ] unit-test-effect -{ 2 0 } [ define-tuple-class ] unit-test-effect -{ 2 0 } [ define-union-class ] unit-test-effect -{ 3 0 } [ define-predicate-class ] unit-test-effect +\ forget must-infer +\ define-class must-infer +\ define-tuple-class must-infer +\ define-union-class must-infer +\ define-predicate-class must-infer ! Test words with continuations { 0 0 } [ [ drop ] callcc0 ] unit-test-effect @@ -423,38 +423,36 @@ DEFER: bar { 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect ! Test stream protocol -{ 2 0 } [ set-timeout ] unit-test-effect -{ 2 1 } [ stream-read ] unit-test-effect -{ 1 1 } [ stream-read1 ] unit-test-effect -{ 1 1 } [ stream-readln ] unit-test-effect -{ 2 2 } [ stream-read-until ] unit-test-effect -{ 2 0 } [ stream-write ] unit-test-effect -{ 2 0 } [ stream-write1 ] unit-test-effect -{ 1 0 } [ stream-nl ] unit-test-effect -{ 1 0 } [ stream-close ] unit-test-effect -{ 3 0 } [ stream-format ] unit-test-effect -{ 3 0 } [ stream-write-table ] unit-test-effect -{ 1 0 } [ stream-flush ] unit-test-effect -{ 2 1 } [ make-span-stream ] unit-test-effect -{ 2 1 } [ make-block-stream ] unit-test-effect -{ 2 1 } [ make-cell-stream ] unit-test-effect +\ set-timeout must-infer +\ stream-read must-infer +\ stream-read1 must-infer +\ stream-readln must-infer +\ stream-read-until must-infer +\ stream-write must-infer +\ stream-write1 must-infer +\ stream-nl must-infer +\ stream-close must-infer +\ stream-format must-infer +\ stream-write-table must-infer +\ stream-flush must-infer +\ make-span-stream must-infer +\ make-block-stream must-infer +\ make-cell-stream must-infer ! Test stream utilities -{ 1 1 } [ lines ] unit-test-effect -{ 1 1 } [ contents ] unit-test-effect +\ lines must-infer +\ contents must-infer ! Test prettyprinting -{ 1 0 } [ . ] unit-test-effect -{ 1 0 } [ short. ] unit-test-effect -{ 1 1 } [ unparse ] unit-test-effect +\ . must-infer +\ short. must-infer +\ unparse must-infer -{ 1 0 } [ describe ] unit-test-effect -{ 1 0 } [ error. ] unit-test-effect +\ describe must-infer +\ error. must-infer ! Test odds and ends -{ 1 1 } [ ' ] unit-test-effect -{ 2 0 } [ write-image ] unit-test-effect -{ 0 0 } [ idle-thread ] unit-test-effect +\ idle-thread must-infer ! Incorrect stack declarations on inline recursive words should ! be caught diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor index 06b80c0ba7..b9f8f3e061 100755 --- a/extra/io/launcher/launcher-tests.factor +++ b/extra/io/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ IN: temporary USING: tools.test tools.test.inference io.launcher ; -{ 1 1 } [ ] unit-test-effect +\ must-infer diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor index 5c222a1b6e..17ff7e1acd 100755 --- a/extra/tools/test/inference/inference.factor +++ b/extra/tools/test/inference/inference.factor @@ -1,5 +1,7 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: effects sequences kernel arrays quotations inference -tools.test ; +tools.test words ; IN: tools.test.inference : short-effect @@ -7,3 +9,8 @@ IN: tools.test.inference : unit-test-effect ( effect quot -- ) >r 1quotation r> [ infer short-effect ] curry unit-test ; + +: must-infer ( word -- ) + dup "declared-effect" word-prop + dup effect-in length swap effect-out length 2array + swap 1quotation unit-test-effect ; diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor index cbccb37111..bc302c1a09 100755 --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -40,7 +40,7 @@ tools.test.inference tools.test.ui models ; ] with-grafted-gadget ] unit-test -{ 0 1 } [ ] unit-test-effect +\ must-infer "hello" "field" set diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 48bb3718cb..81b30559df 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -193,12 +193,12 @@ M: mock-gadget ungraft* { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each ] string-out print -{ 0 1 } [ ] unit-test-effect -{ 1 0 } [ unparent ] unit-test-effect -{ 2 0 } [ add-gadget ] unit-test-effect -{ 2 0 } [ add-gadgets ] unit-test-effect -{ 1 0 } [ clear-gadget ] unit-test-effect +\ must-infer +\ unparent must-infer +\ add-gadget must-infer +\ add-gadgets must-infer +\ clear-gadget must-infer -{ 1 0 } [ relayout ] unit-test-effect -{ 1 0 } [ relayout-1 ] unit-test-effect -{ 1 1 } [ pref-dim ] unit-test-effect +\ relayout must-infer +\ relayout-1 must-infer +\ pref-dim must-infer diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor index 957f38ca26..41f0151746 100755 --- a/extra/ui/tools/workspace/workspace-tests.factor +++ b/extra/ui/tools/workspace/workspace-tests.factor @@ -1,4 +1,4 @@ IN: temporary USING: tools.test tools.test.inference ui.tools ; -{ 0 1 } [ ] unit-test-effect +\ must-infer From b810e924561328f0b4472f3ad56da9cb1175d6a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 21:21:12 -0500 Subject: [PATCH 37/82] Move optimizer to extra/ --- {core => extra}/optimizer/debugger/debugger.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) rename {core => extra}/optimizer/debugger/debugger.factor (97%) mode change 100644 => 100755 diff --git a/core/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor old mode 100644 new mode 100755 similarity index 97% rename from core/optimizer/debugger/debugger.factor rename to extra/optimizer/debugger/debugger.factor index ed0358fe7f..900f5a3829 --- a/core/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -73,8 +73,8 @@ M: #push node>quot nip pushed-literals % ; DEFER: dataflow>quot : #call>quot ( ? node -- ) - dup node-param dup - [ , dup effect-str comment, ] [ 3drop ] if ; + dup node-param dup , + [ dup effect-str ] [ "empty call" ] if comment, ; M: #call node>quot #call>quot ; From 58b25995937c13e7485e26071324b135a3d48758 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 21:37:18 -0500 Subject: [PATCH 38/82] Fix compiler --- core/bootstrap/image/image-tests.factor | 5 ++ core/bootstrap/primitives.factor | 3 +- core/bootstrap/stage2.factor | 4 +- core/compiler/compiler.factor | 3 +- core/compiler/test/simple.factor | 4 ++ core/compiler/test/templates-early.factor | 2 +- core/cpu/x86/bootstrap.factor.new | 68 ----------------------- 7 files changed, 16 insertions(+), 73 deletions(-) create mode 100755 core/bootstrap/image/image-tests.factor mode change 100644 => 100755 core/compiler/test/templates-early.factor delete mode 100755 core/cpu/x86/bootstrap.factor.new diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor new file mode 100755 index 0000000000..901d23e24d --- /dev/null +++ b/core/bootstrap/image/image-tests.factor @@ -0,0 +1,5 @@ +IN: temporary +USING: bootstrap.image tools.test.infer ; + +\ ' must-infer +\ write-image must-infer diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index d379a89142..452e78d765 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -407,7 +407,8 @@ builtins get num-tags get tail f union-class define-class 2array >tuple 1quotation define-inline ! Primitive words -: make-primitive ( word vocab n -- ) >r create r> define ; +: make-primitive ( word vocab n -- ) + >r create dup reset-word r> define ; { { "(execute)" "words.private" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 9e14985551..ce3e03e7e5 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -72,8 +72,8 @@ IN: bootstrap.stage2 [ ] count-words " words total" print "Bootstrapping is complete." print - "Now, you can run ./factor -i=" write - "output-image" get print flush + "Now, you can run Factor:" print + vm write " -i=" write "output-image" get print flush "output-image" get resource-path save-image-and-exit ] if diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index ed21e0a352..c504ed8be4 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -35,7 +35,8 @@ SYMBOL: compiler-hook ] [ print-error f over compiled get set-at f ] recover - 2dup ripple-up save-effect ; + 2drop ; +! 2dup ripple-up save-effect ; : delete-any ( assoc -- element ) [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ; diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor index 5dc07a4818..7ce82c9a1f 100755 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -59,3 +59,7 @@ IN: temporary [ [ dup ] compile-call ] unit-test-fails [ [ drop ] compile-call ] unit-test-fails + +! Regression + +[ ] [ [ callstack ] compile-call drop ] unit-test diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor old mode 100644 new mode 100755 index 8482f4767f..6ad3f3c7b1 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -44,7 +44,7 @@ words kernel math effects ; [ [ ] [ init-templates ] unit-test - [ ] [ init-generator ] unit-test + [ ] [ \ + init-generator ] unit-test [ t ] [ [ end-basic-block ] { } make empty? ] unit-test diff --git a/core/cpu/x86/bootstrap.factor.new b/core/cpu/x86/bootstrap.factor.new deleted file mode 100755 index 35aa34563d..0000000000 --- a/core/cpu/x86/bootstrap.factor.new +++ /dev/null @@ -1,68 +0,0 @@ -[! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs math ; -IN: bootstrap.x86 - -big-endian off - -1 jit-code-format set - -: stack-frame-size 4 bootstrap-cells ; - -[ - arg0 0 MOV - stack-frame-size PUSH ! save stack frame size - arg0 PUSH ! save XT - 0 PUSH ! reserved -] { } make jit-prolog set - -[ - arg0 0 [] MOV ! load literal - ds-reg bootstrap-cell ADD ! increment datastack pointer - ds-reg [] arg0 MOV ! store literal on datastack -] { } make jit-push-literal set - -[ - arg1 stack-reg MOV ! pass callstack pointer as arg 2 -] { } make jit-word-primitive-jump set - -[ - arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2 -] { } make jit-word-primitive-call set - -[ - 0 JMP -] { } make jit-word-jump set - -[ - 0 CALL -] { } make jit-word-call set - -[ - arg1 0 MOV ! load addr of true quotation - arg0 ds-reg [] MOV ! load boolean - ds-reg bootstrap-cell SUB ! pop boolean - arg0 \ f tag-number CMP ! compare it with f - arg0 arg1 [] CMOVE ! load false branch if equal - arg0 arg1 bootstrap-cell [+] CMOVNE ! load true branch if not equal - arg0 quot-xt@ [+] JMP ! execute branch -] { } make jit-if set - -[ - arg1 0 [] MOV ! load dispatch table - arg0 ds-reg [] MOV ! load index - fixnum>slot@ ! turn it into an array offset - ds-reg bootstrap-cell SUB ! pop index - arg0 arg1 ADD ! compute quotation location - arg0 arg0 array-start [+] MOV ! load quotation - arg0 quot-xt@ [+] JMP ! execute branch -] { } make jit-dispatch set - -[ - stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame -] { } make jit-epilog set - -[ 0 RET ] { } make jit-return set - -"bootstrap.x86" forget-vocab From 318b5f40c86be64b01618ee77253dbf3b189b2e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Dec 2007 22:16:14 -0500 Subject: [PATCH 39/82] Update unit tests to use must-infer --- extra/ui/gadgets/books/books-tests.factor | 2 +- extra/ui/gadgets/buttons/buttons-tests.factor | 6 +++--- extra/ui/gadgets/scrollers/scrollers-tests.factor | 2 +- extra/ui/tools/browser/browser-tests.factor | 2 +- extra/ui/tools/interactor/interactor-tests.factor | 2 +- extra/ui/tools/walker/walker-tests.factor | 2 +- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index a7226299ab..35016e1669 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ IN: temporary USING: tools.test.inference ui.gadgets.books ; -{ 2 1 } [ ] unit-test-effect +\ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 8565098e70..a2786ea878 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -28,11 +28,11 @@ T{ foo-gadget } "t" set } "religion" set ] unit-test -{ 2 1 } [ ] unit-test-effect +\ must-infer -{ 2 1 } [ ] unit-test-effect +\ must-infer -{ 2 1 } [ ] unit-test-effect +\ must-infer [ 0 ] [ "religion" get gadget-child radio-control-value diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index a53cf1fb0e..30ba4a18f3 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -86,4 +86,4 @@ dup layout [ t ] [ "s" get @right grid-child slider? ] unit-test [ f ] [ "s" get @right grid-child find-scroller* ] unit-test -{ 1 1 } [ ] unit-test-effect +\ must-infer diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 5a343919e7..3102ad1bd9 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -2,5 +2,5 @@ IN: temporary USING: tools.test tools.test.ui ui.tools.browser tools.test.inference ; -{ 0 1 } [ ] unit-test-effect +\ must-infer [ ] [ [ ] with-grafted-gadget ] unit-test diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index 4963df838c..bf9de10a1e 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,4 @@ IN: temporary USING: ui.tools.interactor tools.test.inference ; -{ 1 1 } [ ] unit-test-effect +\ must-infer diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index eea6d78f22..53903a27b3 100755 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -5,7 +5,7 @@ ui.gadgets.packs vectors ui.tools tools.interpreter tools.interpreter.debug tools.test.inference tools.test.ui ; IN: temporary -{ 0 1 } [ ] unit-test-effect +\ must-infer [ ] [ "walker" set ] unit-test From 9c1454ef68cb878d3577e980b17da9b05f2525c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Dec 2007 17:26:39 -0500 Subject: [PATCH 40/82] Rename real/imaginary slots of complex to real-part/imaginary-part to avoid clashing with the real class word; fix bug where redefining a generic as a class leaves the word in a weird state --- core/bootstrap/primitives.factor | 8 ++++---- core/classes/classes.factor | 1 + core/compiler/compiler-docs.factor | 8 +------- core/compiler/compiler.factor | 12 +++++------ core/compiler/test/intrinsics.factor | 3 ++- core/compiler/test/optimizer.factor | 4 +++- core/compiler/test/templates-early.factor | 17 ++++++++-------- core/compiler/test/templates.factor | 5 ++--- core/generic/generic.factor | 2 +- core/inference/class/class-tests.factor | 11 +++++++++-- core/math/math-docs.factor | 10 ++++++---- core/syntax/syntax-docs.factor | 4 ++-- core/words/words-tests.factor | 22 +++++++++++++++++++++ extra/benchmark/mandel/mandel.factor | 4 ++-- extra/help/cookbook/cookbook.factor | 2 +- extra/math/complex/complex-docs.factor | 4 ++-- extra/math/complex/complex.factor | 7 ++++--- extra/math/functions/functions-tests.factor | 4 ++-- extra/math/functions/functions.factor | 2 +- extra/math/quaternions/quaternions.factor | 2 +- extra/serialize/serialize.factor | 4 ++-- 21 files changed, 83 insertions(+), 53 deletions(-) mode change 100644 => 100755 core/inference/class/class-tests.factor mode change 100644 => 100755 core/syntax/syntax-docs.factor mode change 100644 => 100755 extra/benchmark/mandel/mandel.factor mode change 100644 => 100755 extra/help/cookbook/cookbook.factor mode change 100644 => 100755 extra/math/complex/complex-docs.factor mode change 100644 => 100755 extra/math/quaternions/quaternions.factor mode change 100644 => 100755 extra/serialize/serialize.factor diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 452e78d765..702cc3e47d 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -149,16 +149,16 @@ num-types get f builtins set { { { "real" "math" } - "real" + "real-part" 1 - { "real" "math" } + { "real-part" "math" } f } { { "real" "math" } - "imaginary" + "imaginary-part" 2 - { "imaginary" "math" } + { "imaginary-part" "math" } f } } define-builtin diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 47bf1b8f9c..ee5dd2c7e9 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -253,6 +253,7 @@ PRIVATE> : (define-class) ( word props -- ) over reset-class + over reset-generic over define-symbol >r dup word-props r> union over set-word-props t "class" set-word-prop ; diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index e078a4eee9..0b2b10bf7b 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -5,8 +5,7 @@ IN: compiler ARTICLE: "compiler-usage" "Calling the optimizing compiler" "The main entry point to the optimizing compiler is a single word taking a word as input:" { $subsection compile } -"The optimizing compiler can also compile a single quotation:" -{ $subsection compile-quot } +"The optimizing compiler can also compile and call a single quotation:" { $subsection compile-call } "Three utility words for bulk compilation:" { $subsection compile-batch } @@ -87,11 +86,6 @@ HELP: compile-vocabs { $values { "seq" "a sequence of strings" } } { $description "Compiles all words which have not been compiled yet from the given vocabularies." } ; -HELP: compile-quot -{ $values { "quot" "a quotation" } { "word" "a new, uninterned word" } } -{ $description "Creates a new uninterned word having the given quotation as its definition, and compiles it. The returned word can be passed to " { $link execute } "." } -{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; - HELP: compile-call { $values { "quot" "a quotation" } } { $description "Compiles and runs a quotation." } diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index c504ed8be4..9a48dc2411 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -57,13 +57,13 @@ SYMBOL: compiler-hook : compile ( words -- ) [ compiled? not ] subset recompile ; -: compile-quot ( quot -- word ) +: compile-call ( quot -- ) H{ } clone changed-words [ define-temp dup 1array recompile - ] with-variable ; + ] with-variable execute ; -: compile-call ( quot -- ) - compile-quot execute ; - -: compile-all ( -- ) +: recompile-all ( -- ) all-words recompile ; + +: decompile ( word -- ) + f 2array 1array modify-code-heap ; diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index f383e83a4b..b6c283ed4d 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -324,7 +324,8 @@ cell 8 = [ ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-call dup real swap imaginary + 1 2 [ ] compile-call + dup real-part swap imaginary-part ] unit-test [ 1 2 ] [ diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index d4ed5686f7..45802a0c53 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -170,7 +170,9 @@ GENERIC: void-generic ( obj -- * ) ] unit-test ! compiling with a non-literal class failed -[ t ] [ [ ] compile-quot word? ] unit-test +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test GENERIC: foozul M: reversed foozul ; diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 6ad3f3c7b1..5e2363ede6 100755 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -2,7 +2,7 @@ IN: temporary USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences -words kernel math effects ; +words kernel math effects definitions ; : ( n -- vreg ) T{ int-regs } ; @@ -68,7 +68,7 @@ words kernel math effects ; ! Test template picking strategy SYMBOL: template-chosen -: template-test ( a b -- c ) + ; +: template-test ( a b -- c d ) ; \ template-test { { @@ -76,7 +76,7 @@ SYMBOL: template-chosen 1 template-chosen get push ] H{ { +input+ { { f "obj" } { [ ] "n" } } } - { +output+ { "obj" } } + { +output+ { "obj" "n" } } } } { @@ -84,26 +84,26 @@ SYMBOL: template-chosen 2 template-chosen get push ] H{ { +input+ { { f "obj" } { f "n" } } } - { +output+ { "obj" } } + { +output+ { "obj" "n" } } } } } define-intrinsics [ V{ 2 } ] [ V{ } clone template-chosen set - [ template-test ] compile-quot drop + 0 0 [ template-test ] compile-call 2drop template-chosen get ] unit-test [ V{ 1 } ] [ V{ } clone template-chosen set - [ dup 0 template-test ] compile-quot drop + 1 [ dup 0 template-test ] compile-call 3drop template-chosen get ] unit-test [ V{ 1 } ] [ V{ } clone template-chosen set - [ 0 template-test ] compile-quot drop + 1 [ 0 template-test ] compile-call 2drop template-chosen get ] unit-test @@ -209,7 +209,8 @@ H{ { { f "x" } { f "y" } } define-if-intrinsic [ ] [ - [ 2 template-choice-1 template-choice-2 ] compile-quot drop + [ 2 template-choice-1 template-choice-2 ] + [ define-temp ] with-compilation-unit drop ] unit-test [ V{ "template-choice-1" "template-choice-2" } ] diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor index 46c4225092..70120e6538 100755 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -1,9 +1,8 @@ ! Black box testing of templating optimization - USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private -combinators.private byte-arrays alien layouts ; +combinators.private byte-arrays alien layouts words definitions ; IN: temporary ! Oops! @@ -102,7 +101,7 @@ unit-test [ ] [ [ [ 200 dup [ 200 3array ] curry map drop ] times - ] compile-quot drop + ] [ define-temp ] with-compilation-unit drop ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 9e3520dc27..ed84c0fbd9 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -6,7 +6,7 @@ quotations arrays vocabs ; IN: generic PREDICATE: compound generic ( word -- ? ) - "combination" word-prop ; + "combination" word-prop >boolean ; M: generic definer drop f f ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor old mode 100644 new mode 100755 index d464ffeada..1cfae3301e --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -136,9 +136,16 @@ M: object xyz ; ] set-constraints ] "constraints" set-word-prop +DEFER: blah + [ t ] [ - [ dup V{ } eq? [ foo ] when ] dup second dup push - compile-quot word? + [ + \ blah + [ dup V{ } eq? [ foo ] when ] dup second dup push + define-compound + ] with-compilation-unit + + \ blah compiled? ] unit-test GENERIC: detect-fx ( n -- n ) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 5a004534ef..307a5531a1 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -322,15 +322,17 @@ HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; -HELP: real ( z -- x ) +HELP: real-part ( z -- x ) { $values { "z" number } { "x" real } } -{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } -{ $class-description "The class of real numbers, which is a disjoint union of rationals and floats." } ; +{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } ; -HELP: imaginary ( z -- y ) +HELP: imaginary-part ( z -- y ) { $values { "z" number } { "y" real } } { $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ; +HELP: real +{ $class-description "The class of real numbers, which is a disjoint union of rationals and floats." } ; + HELP: number { $class-description "The class of numbers." } ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor old mode 100644 new mode 100755 index 7072b98b48..4749e6878c --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -286,8 +286,8 @@ HELP: H{ { $examples { $code "H{ { \"tuna\" \"fish\" } { \"jalapeno\" \"vegetable\" } }" } } ; HELP: C{ -{ $syntax "C{ real imaginary }" } -{ $values { "real" "a real number" } { "imaginary" "a real number" } } +{ $syntax "C{ real-part imaginary-part }" } +{ $values { "real-part" "a real number" } { "imaginary-part" "a real number" } } { $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ; HELP: T{ diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 8e05044223..84297e630d 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -161,3 +161,25 @@ SYMBOL: quot-uses-b [ "IN: temporary : undef-test ; << undef-test >>" eval ] catch [ undefined? ] is? ] unit-test + +[ ] [ + "IN: temporary GENERIC: symbol-generic" eval +] unit-test + +[ ] [ + "IN: temporary SYMBOL: symbol-generic" eval +] unit-test + +[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test + +[ ] [ + "IN: temporary GENERIC: symbol-generic" eval +] unit-test + +[ ] [ + "IN: temporary TUPLE: symbol-generic ;" eval +] unit-test + +[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor old mode 100644 new mode 100755 index 7f1da8c71a..f2101f9700 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -34,9 +34,9 @@ SYMBOL: cols : c ( i j -- c ) >r - x-inc * center real x-inc width 2 / * - + >float + x-inc * center real-part x-inc width 2 / * - + >float r> - y-inc * center imaginary y-inc height 2 / * - + >float + y-inc * center imaginary-part y-inc height 2 / * - + >float rect> ; inline : render ( -- ) diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor old mode 100644 new mode 100755 index 854797254f..fc28cff7fa --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -114,7 +114,7 @@ $nl "{ -12 -1 -3 -9 }" } { $references - { "Since quotations are real objects, they can be constructed and taken apart at will. You can write code that writes code. Arrays are just one of the various types of sequences, and the sequence operations such as " { $link each } " and " { $link map } " operate on all types of sequences. There are many more sequence iteration operations than the ones above, too." } + { "Since quotations are objects, they can be constructed and taken apart at will. You can write code that writes code. Arrays are just one of the various types of sequences, and the sequence operations such as " { $link each } " and " { $link map } " operate on all types of sequences. There are many more sequence iteration operations than the ones above, too." } "dataflow" "sequences" } ; diff --git a/extra/math/complex/complex-docs.factor b/extra/math/complex/complex-docs.factor old mode 100644 new mode 100755 index 01a52da0fe..82cb14c391 --- a/extra/math/complex/complex-docs.factor +++ b/extra/math/complex/complex-docs.factor @@ -9,8 +9,8 @@ $nl "Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." $nl "Complex numbers can be taken apart:" -{ $subsection real } -{ $subsection imaginary } +{ $subsection real-part } +{ $subsection imaginary-part } { $subsection >rect } "Complex numbers can be constructed from real numbers:" { $subsection rect> } diff --git a/extra/math/complex/complex.factor b/extra/math/complex/complex.factor index ecd548fefb..236d9df7a0 100755 --- a/extra/math/complex/complex.factor +++ b/extra/math/complex/complex.factor @@ -5,13 +5,14 @@ USING: kernel kernel.private math math.private math.libm math.functions prettyprint.backend arrays math.functions.private sequences parser ; -M: real real ; -M: real imaginary drop 0 ; +M: real real-part ; +M: real imaginary-part drop 0 ; M: complex absq >rect [ sq ] 2apply + ; : 2>rect ( x y -- xr yr xi yi ) - [ [ real ] 2apply ] 2keep [ imaginary ] 2apply ; inline + [ [ real-part ] 2apply ] 2keep + [ imaginary-part ] 2apply ; inline M: complex number= 2>rect number= [ number= ] [ 2drop f ] if ; diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index d957eebd2e..439eaace6f 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -17,8 +17,8 @@ IN: temporary [ 4.0 ] [ 2 2 ^ ] unit-test [ 0.25 ] [ 2 -2 ^ ] unit-test [ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test -[ t ] [ e pi i* ^ real -1.0 = ] unit-test -[ t ] [ e pi i* ^ imaginary -0.00001 0.00001 between? ] unit-test +[ t ] [ e pi i* ^ real-part -1.0 = ] unit-test +[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test [ t ] [ 0 0 ^ fp-nan? ] unit-test [ 1.0/0.0 ] [ 0 -2 ^ ] unit-test diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 34a826f94f..2c1a69a3d5 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -105,7 +105,7 @@ M: real absq sq ; : power-of-2? ( n -- ? ) dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable -: >rect ( z -- x y ) dup real swap imaginary ; inline +: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline : conjugate ( z -- z* ) >rect neg rect> ; inline diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor old mode 100644 new mode 100755 index 4c4d819d8e..d61afd17c3 --- a/extra/math/quaternions/quaternions.factor +++ b/extra/math/quaternions/quaternions.factor @@ -56,7 +56,7 @@ PRIVATE> : q>v ( q -- v ) #! Get the vector part of a quaternion, discarding the real #! part. - first2 >r imaginary r> >rect 3array ; + first2 >r imaginary-part r> >rect 3array ; ! Zero : q0 { 0 0 } ; diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor old mode 100644 new mode 100755 index fd04c86e03..6cc8e60bb6 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -58,8 +58,8 @@ M: float (serialize) ( obj -- ) M: complex (serialize) ( obj -- ) "c" write - dup real (serialize) - imaginary (serialize) ; + dup real-part (serialize) + imaginary-part (serialize) ; M: ratio (serialize) ( obj -- ) "r" write From 52ae410cc5c1a5e981cd232fe6e61683f183c011 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Dec 2007 21:45:16 -0500 Subject: [PATCH 41/82] Removing USE-IF:, add with-interactive-vocabs, other fixes --- core/bootstrap/compiler/compiler.factor | 20 +++- core/bootstrap/syntax.factor | 1 - core/classes/classes-tests.factor | 2 +- core/compiler/compiler.factor | 8 +- core/compiler/test/optimizer.factor | 23 +++-- core/compiler/test/templates-early.factor | 2 +- core/continuations/continuations.factor | 2 +- core/inference/known-words/known-words.factor | 4 +- core/listener/listener-tests.factor | 3 +- core/listener/listener.factor | 3 +- core/parser/parser-docs.factor | 13 +-- core/parser/parser-tests.factor | 7 +- core/parser/parser.factor | 93 ++++++++++--------- core/syntax/syntax-docs.factor | 6 -- core/syntax/syntax.factor | 4 - core/vocabs/loader/loader-docs.factor | 2 +- core/vocabs/loader/loader.factor | 6 +- core/vocabs/vocabs.factor | 7 +- 18 files changed, 109 insertions(+), 97 deletions(-) mode change 100644 => 100755 core/continuations/continuations.factor mode change 100644 => 100755 core/vocabs/loader/loader-docs.factor diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index cc8a78509b..03524ee040 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -13,6 +13,9 @@ IN: bootstrap.compiler 0 profiler-prologue set-global ] when +nl +"Compiling some words to speed up bootstrap..." write + ! Compile a set of words ahead of the full compile. ! This set of words was determined semi-empirically ! using the profiler. It improves bootstrap time @@ -38,20 +41,35 @@ IN: bootstrap.compiler bitand bitor bitxor bitnot } compile +"." write flush + { + 1+ 1- 2/ < <= > >= shift min } compile +"." write flush + { - new nth push pop peek hashcode* = get set + new nth push pop peek +} compile + +"." write flush + +{ + hashcode* = get set } compile { . lines } compile +"." write flush + { malloc free memcpy } compile +" done" print +nl + [ recompile ] recompile-hook set-global diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 8376b8771b..2ddceabe44 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -45,7 +45,6 @@ f swap set-vocab-source-loaded? "TUPLE:" "T{" "UNION:" - "USE-IF:" "USE:" "USING:" "V{" diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 8e513dfdbd..2b82c7e0d6 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -2,7 +2,7 @@ USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes io.streams.string classes.private classes.union classes.mixin classes.predicate -vectors ; +vectors definitions ; IN: temporary H{ } "s" set diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 9a48dc2411..bd11e74ff5 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -8,9 +8,8 @@ IN: compiler SYMBOL: compiler-hook -: compile-begins ( word -- ) - compiler-hook get [ call ] when* - "quiet" get [ drop ] [ "Compiling " write . flush ] if ; +: compile-begins ( -- ) + compiler-hook get [ ] or call ; : compiled-usage ( word -- seq ) #! XXX @@ -29,10 +28,11 @@ SYMBOL: compiler-hook "compiled-effect" set-word-prop ; : (compile) ( word -- ) + compile-begins [ - dup compile-begins dup word-dataflow optimize >r over dup r> generate ] [ + dup inference-error? [ rethrow ] unless print-error f over compiled get set-at f ] recover 2drop ; diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 45802a0c53..ba13dfe776 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -1,7 +1,8 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations -optimizer.backend classes inference.dataflow tuples.private ; +optimizer.backend classes inference.dataflow tuples.private +continuations ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -101,14 +102,14 @@ TUPLE: pred-test ; ! regression -: bad-kill-1 [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline : bad-kill-2 bad-kill-1 drop ; [ 3 ] [ t bad-kill-2 ] unit-test ! regression -: (the-test) ( n -- ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- n ) 2 dup (the-test) ; +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; [ 2 0 ] [ the-test ] unit-test @@ -145,10 +146,10 @@ GENERIC: void-generic ( obj -- * ) [ f ] [ f test-2 ] unit-test -: branch-fold-regression-0 ( n -- ) +: branch-fold-regression-0 ( m -- n ) t [ ] [ 1+ branch-fold-regression-0 ] if ; inline -: branch-fold-regression-1 ( -- ) +: branch-fold-regression-1 ( -- m ) 10 branch-fold-regression-0 ; [ 10 ] [ branch-fold-regression-1 ] unit-test @@ -174,7 +175,7 @@ GENERIC: void-generic ( obj -- * ) [ t ] [ \ -regression compiled? ] unit-test -GENERIC: foozul +GENERIC: foozul ( a -- b ) M: reversed foozul ; M: integer foozul ; M: slice foozul ; @@ -279,3 +280,11 @@ TUPLE: silly-tuple a b ; { silly-tuple-a silly-tuple-b } [ get-slots ] keep ] compile-call ] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 5e2363ede6..801d157ef7 100755 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -76,7 +76,7 @@ SYMBOL: template-chosen 1 template-chosen get push ] H{ { +input+ { { f "obj" } { [ ] "n" } } } - { +output+ { "obj" "n" } } + { +output+ { "obj" "obj" } } } } { diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor old mode 100644 new mode 100755 index dc8f337f33..6bb5a50c4b --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences -namespaces tuples math splitting sorting quotations assocs ; +namespaces math splitting sorting quotations assocs ; IN: continuations SYMBOL: error diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index d539e09e7d..46b1aa8712 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -79,8 +79,8 @@ M: curried infer-call M: composed infer-call infer-uncurry - infer->r peek-d infer-call infer-r> - peek-d infer-call ; + infer->r peek-d infer-call + terminated? get [ infer-r> peek-d infer-call ] unless ; M: object infer-call \ literal-expected inference-warning ; diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 2e5b6ccb1c..fc2dacdd15 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -12,7 +12,6 @@ IN: temporary ] unit-test [ - file-vocabs "debugger" use+ [ [ \ + 1 2 3 4 ] ] @@ -26,7 +25,7 @@ IN: temporary "USE: debugger :1" eval ] callcc1 ] unit-test -] with-scope +] with-file-vocabs [ ] [ "vocabs.loader.test.c" forget-vocab diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 151b08151f..6f94d92d93 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -60,7 +60,6 @@ M: duplex-stream stream-read-quot " on " write os write "/" write cpu print ; : listener ( -- ) - print-banner - [ use [ clone ] change until-quit ] with-scope ; + print-banner [ until-quit ] with-interactive-vocabs ; MAIN: listener diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 4dce1bd455..6a12632a60 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -327,7 +327,7 @@ HELP: still-parsing? HELP: use { $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; -{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: file-vocabs } related-words +{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: with-with-default-vocabs } related-words HELP: in { $var-description "A variable holding the name of the current vocabulary for new definitions." } ; @@ -477,12 +477,13 @@ $parsing-note ; HELP: bootstrap-syntax { $var-description "Only set during bootstrap. Stores a copy of the " { $link vocab-words } " of the host's syntax vocabulary; this allows the host's parsing words to be used during bootstrap source parsing, not the target's." } ; -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: with-file-vocabs +{ $values { "quot" quotation } } +{ $description "Calls the quotation in a scope with 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-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 } ")." } +{ $description "Parses Factor source code in a sequence of lines. The initial vocabulary search path is used (see " { $link with-file-vocabs } ")." } { $errors "Throws a parse error if the input is malformed." } ; HELP: eval @@ -533,10 +534,6 @@ 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." } ; -HELP: ?bootstrap-file -{ $values { "path" "a pathname string" } } -{ $description "If the file exists, loads it with " { $link bootstrap-file } ", otherwise does nothing." } ; - HELP: eval>string { $values { "str" string } { "output" string } } { $description "Evaluates the Factor code in " { $snippet "str" } " with the " { $link stdio } " stream rebound to a string output stream, then outputs the resulting string." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 8b18969b7b..5591cff26a 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -5,8 +5,6 @@ sorting tuples ; IN: temporary [ - file-vocabs - [ 1 CHAR: a ] [ 0 "abcd" next-char ] unit-test @@ -111,8 +109,7 @@ IN: temporary { "scratchpad" "arrays" } set-use [ ! This shouldn't modify in/use in the outer scope! - file-vocabs - ] with-scope + ] with-file-vocabs use get { "scratchpad" "arrays" } set-use use get = ] with-scope @@ -368,7 +365,7 @@ IN: temporary "redefining-a-class-4" parse-stream drop ] catch [ redefine-error? ] is? ] unit-test -] with-scope +] with-file-vocabs [ << file get parsed >> file set diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1d140ac3b6..e027cad50f 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -338,13 +338,56 @@ M: bad-number summary SYMBOL: bootstrap-syntax -: file-vocabs ( -- ) - "scratchpad" in set - { "syntax" "scratchpad" } set-use - bootstrap-syntax get [ use get push ] when* ; +: with-file-vocabs ( quot -- ) + [ + "scratchpad" in set + { "syntax" "scratchpad" } set-use + bootstrap-syntax get [ use get push ] when* + call + ] with-scope ; inline + +: with-interactive-vocabs ( quot -- ) + [ + "scratchpad" in set + { + "scratchpad" + "arrays" + "assocs" + "combinators" + "compiler" + "continuations" + "debugger" + "definitions" + "generic" + "inspector" + "io" + "io.files" + "kernel" + "math" + "memory" + "namespaces" + "prettyprint" + "sequences" + "slicing" + "sorting" + "strings" + "syntax" + "vocabs" + "vocabs.loader" + "words" + "tools.annotations" + "tools.crossref" + "tools.memory" + "tools.profiler" + "tools.test" + "tools.time" + "editors" + } set-use + call + ] with-scope ; inline : parse-fresh ( lines -- quot ) - [ file-vocabs parse-lines ] with-scope ; + [ parse-lines ] with-file-vocabs ; : parsing-file ( file -- ) "quiet" get [ @@ -426,14 +469,7 @@ SYMBOL: bootstrap-syntax dup ?resource-path exists? [ run-file ] [ drop ] if ; : bootstrap-file ( path -- ) - [ - parse-file [ call ] curry % - ] [ - run-file - ] if-bootstrapping ; - -: ?bootstrap-file ( path -- ) - dup ?resource-path exists? [ bootstrap-file ] [ drop ] if ; + [ parse-file % ] [ run-file ] if-bootstrapping ; : eval ( str -- ) [ string-lines parse-fresh ] with-compilation-unit call ; @@ -443,34 +479,3 @@ SYMBOL: bootstrap-syntax parser-notes off [ [ eval ] keep ] try drop ] string-out ; - -global [ - { - "scratchpad" - "arrays" - "assocs" - "combinators" - "compiler" - "continuations" - "debugger" - "definitions" - "generic" - "inspector" - "io" - "kernel" - "math" - "memory" - "namespaces" - "parser" - "prettyprint" - "sequences" - "slicing" - "sorting" - "strings" - "syntax" - "vocabs" - "vocabs.loader" - "words" - } set-use - "scratchpad" set-in -] bind diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 4749e6878c..a947362617 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -357,12 +357,6 @@ HELP: USE: { $description "Adds a new vocabulary at the front of the search path. Subsequent word lookups by the parser will search this vocabulary first." } { $errors "Throws an error if the vocabulary does not exist." } ; -HELP: USE-IF: -{ $syntax "USE-IF: word vocabulary" } -{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "vocabulary" "a vocabulary name" } } -{ $description "Adds a vocabulary at the front of the search path if the word evaluates to a true value." } -{ $errors "Throws an error if the vocabulary does not exist." } ; - HELP: USING: { $syntax "USING: vocabularies... ;" } { $values { "vocabularies" "a list of vocabulary names" } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index f3f4adc62c..552c7480a3 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -47,10 +47,6 @@ IN: bootstrap.syntax "USE:" [ scan use+ ] define-syntax - "USE-IF:" [ - scan-word scan swap execute [ use+ ] [ drop ] if - ] define-syntax - "USING:" [ ";" parse-tokens add-use ] define-syntax "HEX:" [ 16 parse-base ] define-syntax diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor old mode 100644 new mode 100755 index d4ef697a15..ec56cc8645 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -73,7 +73,7 @@ HELP: vocab-files HELP: no-vocab { $values { "name" "a vocabulary name" } } { $description "Throws a " { $link no-vocab } "." } -{ $error-description "Thrown when a " { $link POSTPONE: USE: } ", " { $link POSTPONE: USING: } " or " { $link POSTPONE: USE-IF: } " form refers to a non-existent vocabulary." } ; +{ $error-description "Thrown when a " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " form refers to a non-existent vocabulary." } ; HELP: load-help? { $var-description "If set to a true value, documentation will be automatically loaded when vocabularies are loaded. This variable is usually on, except when Factor has been bootstrapped without the help system." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index e24955481b..a5d29804ad 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -75,13 +75,13 @@ SYMBOL: load-help? : docs-were-loaded t swap set-vocab-docs-loaded? ; -: docs-were't-loaded f swap set-vocab-docs-loaded? ; +: docs-weren't-loaded f swap set-vocab-docs-loaded? ; : load-docs ( root name -- ) load-help? get [ [ docs-were-loaded ] keep [ - [ vocab-docs path+ ?bootstrap-file ] - [ ] [ docs-were't-loaded ] + [ vocab-docs path+ ?run-file ] + [ ] [ docs-weren't-loaded ] cleanup ] keep source-was-loaded ] [ diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 861a977891..66eecf0b1e 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -13,8 +13,8 @@ main help source-loaded? docs-loaded? ; : ( name -- vocab ) - H{ } clone - { set-vocab-name set-vocab-words } + H{ } clone t + { set-vocab-name set-vocab-words set-vocab-source-loaded? } \ vocab construct ; GENERIC: vocab ( vocab-spec -- vocab ) @@ -54,8 +54,7 @@ M: f vocab-docs-loaded? ; M: f set-vocab-docs-loaded? 2drop ; : create-vocab ( name -- vocab ) - dictionary get [ ] cache - t over set-vocab-source-loaded? ; + dictionary get [ ] cache ; SYMBOL: load-vocab-hook From ced9893a4e4279b7a7894d992f1044dc0f578c74 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Dec 2007 21:46:06 -0500 Subject: [PATCH 42/82] Get bootstrap.tools to load, update extra/ for USE-IF: removal --- extra/bootstrap/tools/tools.factor | 11 +++------ extra/calendar/calendar.factor | 18 +++++++-------- extra/channels/sniffer/sniffer.factor | 5 ++--- extra/editors/gvim/gvim.factor | 9 +++++--- extra/hardware-info/hardware-info.factor | 11 +++++---- extra/hardware-info/windows/windows.factor | 9 ++++---- extra/help/syntax/syntax.factor | 2 +- extra/io/launcher/launcher.factor | 8 +++---- extra/io/mmap/mmap.factor | 8 ++++--- extra/io/sniffer/filter/filter.factor | 13 +++++------ extra/io/sniffer/sniffer.factor | 4 ++-- extra/io/sockets/impl/impl.factor | 8 ++++--- extra/tools/annotations/annotations.factor | 26 ++++++++++++++++------ extra/tools/browser/browser.factor | 4 ++-- extra/tools/deploy/deploy.factor | 5 ++--- extra/ui/tools/listener/listener.factor | 3 +-- extra/unix/unix.factor | 12 +++++----- 17 files changed, 85 insertions(+), 71 deletions(-) mode change 100644 => 100755 extra/bootstrap/tools/tools.factor mode change 100644 => 100755 extra/calendar/calendar.factor mode change 100644 => 100755 extra/channels/sniffer/sniffer.factor mode change 100644 => 100755 extra/editors/gvim/gvim.factor mode change 100644 => 100755 extra/hardware-info/hardware-info.factor mode change 100644 => 100755 extra/hardware-info/windows/windows.factor mode change 100644 => 100755 extra/io/sniffer/filter/filter.factor mode change 100644 => 100755 extra/io/sniffer/sniffer.factor mode change 100644 => 100755 extra/io/sockets/impl/impl.factor mode change 100644 => 100755 extra/tools/browser/browser.factor mode change 100644 => 100755 extra/ui/tools/listener/listener.factor mode change 100644 => 100755 extra/unix/unix.factor diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor old mode 100644 new mode 100755 index f3ec0a88e8..f94bf80bbf --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -1,4 +1,4 @@ -USING: kernel vocabs vocabs.loader sequences namespaces parser ; +USING: vocabs.loader sequences ; { "bootstrap.image" @@ -6,14 +6,9 @@ USING: kernel vocabs vocabs.loader sequences namespaces parser ; "tools.crossref" "tools.deploy" "tools.memory" + "tools.profiler" "tools.test" "tools.time" "tools.walker" "editors" -} dup [ require ] each - -global [ add-use ] bind - -"bootstrap.compiler" vocab [ - "tools.profiler" dup require use+ -] when +} [ require ] each diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor old mode 100644 new mode 100755 index 55d632d245..63c7532b61 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,9 +3,13 @@ USING: arrays hashtables io io.streams.string kernel math math.vectors math.functions math.parser namespaces sequences -strings tuples system debugger ; +strings tuples system debugger combinators vocabs.loader ; IN: calendar +SYMBOL: calendar-impl + +HOOK: gmt-offset calendar-impl ( -- n ) + TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp @@ -14,8 +18,6 @@ TUPLE: dt year month day hour minute second ; C:
dt -DEFER: gmt-offset - : month-names { "Not a month" "January" "February" "March" "April" "May" "June" @@ -351,9 +353,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) ] if ] string-out ; -SYMBOL: calendar-impl - -HOOK: gmt-offset calendar-impl ( -- n ) - -USE-IF: unix? calendar.unix -USE-IF: windows? calendar.windows +{ + { [ unix? ] [ "calendar.unix" ] } + { [ windows? ] [ "calendar.windows" ] } +} cond require diff --git a/extra/channels/sniffer/sniffer.factor b/extra/channels/sniffer/sniffer.factor old mode 100644 new mode 100755 index 7c97c2e244..8edd035cca --- a/extra/channels/sniffer/sniffer.factor +++ b/extra/channels/sniffer/sniffer.factor @@ -3,12 +3,11 @@ ! ! Wrap a sniffer in a channel USING: kernel channels concurrency io io.backend -io.sniffer system ; +io.sniffer system vocabs.loader ; : (sniff-channel) ( stream channel -- ) 4096 pick stream-read-partial over to (sniff-channel) ; HOOK: sniff-channel io-backend ( -- channel ) -USE-IF: bsd? channels.sniffer.bsd - +bsd? [ "channels.sniffer.bsd" require ] when diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor old mode 100644 new mode 100755 index 7a1f939b5c..8b3573d03e --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -1,5 +1,6 @@ USING: io.backend io.files kernel math math.parser -namespaces editors.vim sequences system ; +namespaces editors.vim sequences system combinators +vocabs.loader ; IN: editors.gvim TUPLE: gvim ; @@ -14,5 +15,7 @@ t vim-detach set-global ! don't block the ui T{ gvim } vim-editor set-global -USE-IF: unix? editors.gvim.unix -USE-IF: windows? editors.gvim.windows +{ + { [ unix? ] [ "editors.gvim.unix" ] } + { [ windows? ] [ "editors.gvim.windows" ] } +} cond require diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor old mode 100644 new mode 100755 index 521ec3d95f..9b3c969dc3 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,4 +1,5 @@ -USING: alien.syntax math prettyprint system ; +USING: alien.syntax math prettyprint system combinators +vocabs.loader ; IN: hardware-info SYMBOL: os @@ -17,7 +18,9 @@ HOOK: available-virtual-extended-mem os ( -- n ) : megs. ( x -- ) 20 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ; -USE-IF: windows? hardware-info.windows -USE-IF: linux? hardware-info.linux -USE-IF: macosx? hardware-info.macosx +{ + { [ windows? ] [ "hardware-info.windows" ] } + { [ linux? ] [ "hardware-info.linux" ] } + { [ macosx? ] [ "hardware-info.macosx" ] } +} cond require diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor old mode 100644 new mode 100755 index 88e9a8cfb5..5352d64698 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 hardware-info -words ; +words combinators vocabs.loader ; IN: hardware-info.windows TUPLE: wince ; @@ -70,6 +70,7 @@ M: windows cpus ( -- n ) : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; -USE-IF: wince? hardware-info.windows.ce -USE-IF: winnt? hardware-info.windows.nt - +{ + { [ wince? ] [ "hardware-info.windows.ce" ] } + { [ winnt? ] [ "hardware-info.windows.nt" ] } +} cond require diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor index 6d287de60f..7ffa83c0d7 100755 --- a/extra/help/syntax/syntax.factor +++ b/extra/help/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel parser sequences words help help.topics -namespaces vocabs ; +namespaces vocabs definitions ; IN: help.syntax : HELP: diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 114a50597c..7de9d91bc7 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend system kernel namespaces strings hashtables -sequences assocs combinators ; +sequences assocs combinators vocabs.loader ; IN: io.launcher SYMBOL: +command+ @@ -57,6 +57,6 @@ HOOK: process-stream* io-backend ( desc -- stream ) : ( obj -- stream ) >descriptor process-stream* ; -USE-IF: unix? io.unix.launcher -USE-IF: windows? io.windows.launcher -USE-IF: winnt? io.windows.nt.launcher +unix? [ "io.unix.launcher" require ] when +windows? [ "io.windows.launcher" require ] when +winnt? [ "io.windows.nt.launcher" require ] when diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index aaa786f6a4..37ae0617f8 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: continuations io.backend kernel quotations sequences -system alien sequences.private ; +system alien sequences.private combinators vocabs.loader ; IN: io.mmap TUPLE: mapped-file length address handle closed? ; @@ -35,5 +35,7 @@ HOOK: (close-mapped-file) io-backend ( mmap -- ) [ keep ] curry [ close-mapped-file ] [ ] cleanup ; inline -USE-IF: unix? io.unix.mmap -USE-IF: windows? io.windows.mmap +{ + { [ unix? ] [ "io.unix.mmap" ] } + { [ windows? ] [ "io.windows.mmap" ] } +} cond require diff --git a/extra/io/sniffer/filter/filter.factor b/extra/io/sniffer/filter/filter.factor old mode 100644 new mode 100755 index 9a9a5be978..3240810e7f --- a/extra/io/sniffer/filter/filter.factor +++ b/extra/io/sniffer/filter/filter.factor @@ -1,6 +1,6 @@ -USING: alien.c-types byte-arrays combinators hexdump io io.backend -io.streams.string io.sockets.headers kernel math prettyprint -io.sniffer sequences system ; +USING: alien.c-types byte-arrays combinators hexdump io +io.backend io.streams.string io.sockets.headers kernel math +prettyprint io.sniffer sequences system vocabs.loader ; IN: io.sniffer.filter HOOK: sniffer-loop io-backend ( stream -- ) @@ -14,9 +14,6 @@ HOOK: packet. io-backend ( string -- ) ! HEX: 800 [ ] ! IP ! HEX: 806 [ ] ! ARP [ "Unknown type: " write .h ] - } case - - drop drop ; - -USE-IF: bsd? io.sniffer.filter.bsd + } case 2drop ; +bsd? [ "io.sniffer.filter.bsd" require ] when diff --git a/extra/io/sniffer/sniffer.factor b/extra/io/sniffer/sniffer.factor old mode 100644 new mode 100755 index 69ebc0bf5a..04491ca709 --- a/extra/io/sniffer/sniffer.factor +++ b/extra/io/sniffer/sniffer.factor @@ -1,4 +1,4 @@ -USING: io.backend kernel system ; +USING: io.backend kernel system vocabs.loader ; IN: io.sniffer SYMBOL: sniffer-type @@ -7,4 +7,4 @@ TUPLE: sniffer ; HOOK: io-backend ( obj -- sniffer ) -USE-IF: bsd? io.sniffer.bsd +bsd? [ "io.sniffer.bsd" require ] when diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor old mode 100644 new mode 100755 index 426eda9c76..e490b9312b --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -2,11 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays byte-arrays io.backend io.binary io.sockets kernel math math.parser sequences splitting system -alien.c-types combinators namespaces alien ; +alien.c-types combinators namespaces alien parser ; IN: io.sockets.impl -USE-IF: windows? windows.winsock -USE-IF: unix? unix +<< { + { [ windows? ] [ "windows.winsock" ] } + { [ unix? ] [ "unix" ] } +} cond use+ >> GENERIC: protocol-family ( addrspec -- af ) diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 87dd1ecd6b..018b91d219 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -1,15 +1,25 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words parser io inspector quotations sequences -prettyprint continuations effects ; +prettyprint continuations effects definitions ; IN: tools.annotations -: reset "not implemented yet" throw ; +r >r word-def r> call r> - swap define-compound do-parse-hook ; - inline + over check-compound + [ + >r dup word-def r> call define-compound + ] with-compilation-unit ; inline : entering ( str -- ) "/-- Entering: " write dup . @@ -32,11 +42,13 @@ IN: tools.annotations rot [ leaving ] curry swapd 3append ; +PRIVATE> + : watch ( word -- ) dup [ (watch) ] annotate ; : breakpoint ( word -- ) [ \ break add* ] annotate ; -: breakpoint-if ( quot word -- ) - [ [ [ break ] when ] swap 3append ] annotate ; +: breakpoint-if ( word quot -- ) + [ [ [ break ] when ] rot 3append ] curry annotate ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor old mode 100644 new mode 100755 index 97d3c968cb..51c042d822 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -117,7 +117,7 @@ M: vocab-link summary vocab-summary ; : load-everything ( -- ) all-vocabs-seq [ vocab-name dangerous? not ] subset - [ [ require ] each ] no-parse-hook ; + [ require ] each ; : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless @@ -137,7 +137,7 @@ M: vocab-link summary vocab-summary ; : load-children ( prefix -- ) all-child-vocabs values concat - [ [ require ] each ] no-parse-hook ; + [ require ] each ; : vocab-status-string ( vocab -- string ) { diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index dafe44dfad..7a3fbb8fdd 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -64,6 +64,5 @@ SYMBOL: deploy-implementation HOOK: deploy deploy-implementation ( vocab -- ) -USE-IF: macosx? tools.deploy.macosx - -USE-IF: winnt? tools.deploy.windows +macosx? [ "tools.deploy.macosx" require ] when +winnt? [ "tools.deploy.windows" require ] when diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor old mode 100644 new mode 100755 index 7d7c7c1ea9..26910ac7b4 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -74,8 +74,7 @@ M: listener-operation invoke-command ( target command -- ) dup empty? [ drop ] [ - [ [ [ run-file ] each ] no-parse-hook ] curry - call-listener + [ [ run-file ] each ] curry call-listener ] if ; : com-EOF ( listener -- ) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor old mode 100644 new mode 100755 index 10ff7a9efa..94bb598c25 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: unix USING: alien alien.c-types alien.syntax kernel libc structs -math namespaces system ; +math namespaces system combinators vocabs.loader ; ! ! ! Unix types TYPEDEF: int blksize_t @@ -24,10 +24,6 @@ TYPEDEF: ushort mode_t TYPEDEF: ushort nlink_t TYPEDEF: void* caddr_t -USE-IF: linux? unix.linux -USE-IF: bsd? unix.bsd -USE-IF: solaris? unix.solaris - C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 @@ -204,3 +200,9 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; + +{ + { [ linux? ] [ "unix.linux" ] } + { [ bsd? ] [ "unix.bsd" ] } + { [ solaris? ] [ "unix.solaris" ] } +} cond require From 1caa78f618d2414f2f58388f0a904a66a624d5f4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Dec 2007 21:50:09 -0500 Subject: [PATCH 43/82] Fixes for with-interactive-vocabs change --- core/bootstrap/stage2.factor | 1 - core/parser/parser.factor | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index ce3e03e7e5..e8539d79e0 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -35,7 +35,6 @@ IN: bootstrap.stage2 ] [ "listener" require "none" require - "listener" use+ ] if "exclude" "include" diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e027cad50f..3b9ba714f2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -382,6 +382,7 @@ SYMBOL: bootstrap-syntax "tools.test" "tools.time" "editors" + "listener" } set-use call ] with-scope ; inline From 58da31c071fad92f124457b053b8f1901397832a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Dec 2007 22:51:36 -0500 Subject: [PATCH 44/82] New implementation of compiler error reporting --- core/bootstrap/stage2.factor | 24 ++++---- core/compiler/compiler.factor | 6 +- core/compiler/errors/errors.factor | 56 +++++++++++++++++++ core/continuations/continuations-tests.factor | 35 ++++++++++++ core/inference/backend/backend.factor | 5 +- core/parser/parser.factor | 12 ++-- core/vocabs/loader/loader.factor | 13 +++-- extra/tools/annotations/annotations.factor | 2 +- extra/tools/browser/browser.factor | 4 +- 9 files changed, 131 insertions(+), 26 deletions(-) create mode 100755 core/compiler/errors/errors.factor diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index e8539d79e0..df9e59aec5 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -4,7 +4,7 @@ USING: init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings -definitions assocs ; +definitions assocs compiler.errors ; IN: bootstrap.stage2 ! Wrap everything in a catch which starts a listener so @@ -37,21 +37,25 @@ IN: bootstrap.stage2 "none" require ] if - "exclude" "include" - [ get-global " " split [ empty? not ] subset ] 2apply - seq-diff - [ "bootstrap." swap append require ] each + [ + "exclude" "include" + [ get-global " " split [ empty? not ] subset ] 2apply + seq-diff + [ "bootstrap." swap append require ] each - init-io - init-stdio + init-io + init-stdio - run-bootstrap-init + run-bootstrap-init + + "Compiling remaining words..." print + + all-words [ compiled? not ] subset recompile-hook get call + ] with-compiler-errors f error set-global f error-continuation set-global - all-words [ compiled? not ] subset recompile-hook get call - "deploy-vocab" get [ "tools.deploy.shaker" run ] [ diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index bd11e74ff5..0d4812626c 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -3,7 +3,7 @@ USING: kernel namespaces arrays sequences io inference.backend generator debugger math.parser prettyprint words words.private continuations vocabs assocs alien.compiler dlists optimizer -definitions ; +definitions math compiler.errors ; IN: compiler SYMBOL: compiler-hook @@ -33,7 +33,7 @@ SYMBOL: compiler-hook dup word-dataflow optimize >r over dup r> generate ] [ dup inference-error? [ rethrow ] unless - print-error f over compiled get set-at f + over compiler-error f over compiled get set-at f ] recover 2drop ; ! 2dup ripple-up save-effect ; @@ -63,7 +63,7 @@ SYMBOL: compiler-hook ] with-variable execute ; : recompile-all ( -- ) - all-words recompile ; + [ all-words recompile ] with-compiler-errors ; : decompile ( word -- ) f 2array 1array modify-code-heap ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor new file mode 100755 index 0000000000..106b69893b --- /dev/null +++ b/core/compiler/errors/errors.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces assocs prettyprint io sequences +sorting continuations debugger math ; +IN: compiler.errors + +SYMBOL: compiler-errors + +SYMBOL: with-compiler-errors? + +: compiler-error ( error word -- ) + with-compiler-errors? get [ + compiler-errors get set-at + ] [ 2drop ] if ; + +: compiler-error. ( error word -- ) + nl + "While compiling " write pprint ": " print + nl + print-error ; + +: compiler-errors. ( assoc -- ) + >alist sort-keys [ swap compiler-error. ] assoc-each ; + +GENERIC: compiler-warning? ( error -- ? ) + +: (:errors) ( -- assoc ) + compiler-errors get-global + [ nip compiler-warning? not ] assoc-subset ; + +: :errors (:errors) compiler-errors. ; + +: (:warnings) ( -- seq ) + compiler-errors get-global + [ nip compiler-warning? ] assoc-subset ; + +: :warnings (:warnings) compiler-errors. ; + +: (compiler-report) ( what assoc -- ) + length dup zero? [ 2drop ] [ + ":" write over write " - print " write pprint + " compiler " write write "." print + ] if ; + +: compiler-report ( -- ) + "errors" (:errors) (compiler-report) + "warnings" (:warnings) (compiler-report) ; + +: with-compiler-errors ( quot -- ) + with-compiler-errors? get "quiet" get or [ call ] [ + [ + with-compiler-errors? on + V{ } clone compiler-errors set-global + [ compiler-report ] [ ] cleanup + ] with-scope + ] if ; inline diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index d4a8cfb6a6..667d81a30e 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -71,3 +71,38 @@ IN: temporary [ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test + +SYMBOL: always-counter +SYMBOL: error-counter + +[ + 0 always-counter set + 0 error-counter set + + [ ] [ always-counter inc ] [ error-counter inc ] cleanup + + [ 1 ] [ always-counter get ] unit-test + [ 0 ] [ error-counter get ] unit-test + + [ "a" ] [ + [ + [ "a" throw ] + [ always-counter inc ] + [ error-counter inc ] cleanup + ] catch + ] unit-test + + [ 2 ] [ always-counter get ] unit-test + [ 1 ] [ error-counter get ] unit-test + + [ "a" ] [ + [ + [ ] + [ always-counter inc "a" throw ] + [ error-counter inc ] cleanup + ] catch + ] unit-test + + [ 3 ] [ always-counter get ] unit-test + [ 2 ] [ error-counter get ] unit-test +] with-scope diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index f2f153e0bd..520b0ec485 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -4,7 +4,7 @@ IN: inference.backend USING: inference.dataflow arrays generic io io.streams.string kernel math namespaces parser prettyprint sequences strings vectors words quotations effects classes continuations -debugger assocs combinators ; +debugger assocs combinators compiler.errors ; : recursive-label ( word -- label/f ) recursive-state get at ; @@ -22,6 +22,9 @@ debugger assocs combinators ; TUPLE: inference-error rstate major? ; +M: inference-error compiler-warning? + inference-error-major? not ; + : (inference-error) ( ... class important? -- * ) >r construct-boa r> recursive-state get { diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 3b9ba714f2..d3efd54904 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,7 +5,7 @@ namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string io.streams.lines vocabs -source-files classes hashtables ; +source-files classes hashtables compiler.errors ; IN: parser TUPLE: lexer text line column ; @@ -354,7 +354,7 @@ SYMBOL: bootstrap-syntax "arrays" "assocs" "combinators" - "compiler" + "compiler.errors" "continuations" "debugger" "definitions" @@ -455,9 +455,11 @@ SYMBOL: bootstrap-syntax : parse-file ( file -- quot ) [ - [ parsing-file ] keep - [ ?resource-path ] keep - parse-stream + [ + [ parsing-file ] keep + [ ?resource-path ] keep + parse-stream + ] with-compiler-errors ] [ over parse-file-restarts rethrow-restarts drop parse-file diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index a5d29804ad..306f357b72 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -3,7 +3,8 @@ USING: namespaces splitting sequences io.files kernel assocs words vocabs definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint -source-files arrays combinators strings system math.parser ; +source-files arrays combinators strings system math.parser +compiler.errors ; IN: vocabs.loader SYMBOL: vocab-roots @@ -108,7 +109,8 @@ SYMBOL: load-help? drop no-vocab ] if ; -: require ( vocab -- ) load-vocab drop ; +: require ( vocab -- ) + load-vocab drop ; : run ( vocab -- ) dup load-vocab vocab-main [ @@ -150,11 +152,14 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; +: require-each ( seq -- ) + [ [ require ] each ] with-compiler-errors ; + : do-refresh ( modified-sources modified-docs -- ) 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune [ require ] each ; + append prune require-each ; : refresh ( prefix -- ) to-refresh do-refresh ; @@ -172,7 +177,7 @@ M: string (load-vocab) M: vocab-link (load-vocab) vocab-name (load-vocab) ; -[ dup vocab [ ] [ ] ?if (load-vocab) ] +[ [ dup vocab [ ] [ ] ?if (load-vocab) ] with-compiler-errors ] load-vocab-hook set-global : vocab-where ( vocab -- loc ) diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 018b91d219..27c427ad25 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -6,7 +6,7 @@ IN: tools.annotations Date: Fri, 28 Dec 2007 22:52:00 -0500 Subject: [PATCH 45/82] Freetype staging violation fix --- extra/freetype/freetype.factor | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) mode change 100644 => 100755 extra/freetype/freetype.factor diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor old mode 100644 new mode 100755 index b7fc1d66ab..e32f14432b --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -3,14 +3,11 @@ USING: alien alien.syntax kernel system combinators ; IN: freetype -: load-freetype-library ( -- ) - "freetype" { - { [ macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] } - { [ windows? ] [ "freetype6.dll" "cdecl" add-library ] } - { [ t ] [ drop ] } - } cond ; parsing - -load-freetype-library +<< "freetype" { + { [ macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] } + { [ windows? ] [ "freetype6.dll" "cdecl" add-library ] } + { [ t ] [ drop ] } +} cond >> LIBRARY: freetype From 78029f54642e6cb59b4377372036c05eb3691ebf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Dec 2007 22:52:24 -0500 Subject: [PATCH 46/82] windows.messages staging violation load fix --- extra/windows/messages/messages.factor | 1990 ++++++++++++------------ 1 file changed, 994 insertions(+), 996 deletions(-) mode change 100644 => 100755 extra/windows/messages/messages.factor diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor old mode 100644 new mode 100755 index 5e19f3bf0d..733071d197 --- a/extra/windows/messages/messages.factor +++ b/extra/windows/messages/messages.factor @@ -1,1005 +1,1003 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs hashtables kernel math namespaces parser prettyprint words windows.types ; +USING: assocs hashtables kernel math namespaces words +windows.types vocabs sequences ; IN: windows.messages SYMBOL: windows-messages -: maybe-create-windows-messages - global [ windows-messages - [ H{ } assoc-like ] change ] bind ; - -: add-windows-message ( -- ) - word [ word-name ] keep execute maybe-create-windows-messages - windows-messages get set-at ; parsing +"windows.messages" words +[ word-name "windows-message" head? not ] subset +[ dup execute swap ] { } map>assoc +windows-messages set-global : windows-message-name ( n -- name ) - windows-messages get at* [ drop "unknown message" ] unless ; + windows-messages get at "unknown message" or ; -: WM_NULL HEX: 0000 ; inline add-windows-message -: WM_CREATE HEX: 0001 ; inline add-windows-message -: WM_DESTROY HEX: 0002 ; inline add-windows-message -: WM_MOVE HEX: 0003 ; inline add-windows-message -: WM_SIZE HEX: 0005 ; inline add-windows-message -: WM_ACTIVATE HEX: 0006 ; inline add-windows-message -: WM_SETFOCUS HEX: 0007 ; inline add-windows-message -: WM_KILLFOCUS HEX: 0008 ; inline add-windows-message -: WM_ENABLE HEX: 000A ; inline add-windows-message -: WM_SETREDRAW HEX: 000B ; inline add-windows-message -: WM_SETTEXT HEX: 000C ; inline add-windows-message -: WM_GETTEXT HEX: 000D ; inline add-windows-message -: WM_GETTEXTLENGTH HEX: 000E ; inline add-windows-message -: WM_PAINT HEX: 000F ; inline add-windows-message -: WM_CLOSE HEX: 0010 ; inline add-windows-message -: WM_QUERYENDSESSION HEX: 0011 ; inline add-windows-message -: WM_QUERYOPEN HEX: 0013 ; inline add-windows-message -: WM_ENDSESSION HEX: 0016 ; inline add-windows-message -: WM_QUIT HEX: 0012 ; inline add-windows-message -: WM_ERASEBKGND HEX: 0014 ; inline add-windows-message -: WM_SYSCOLORCHANGE HEX: 0015 ; inline add-windows-message -: WM_SHOWWINDOW HEX: 0018 ; inline add-windows-message -: WM_WININICHANGE HEX: 001A ; inline add-windows-message -: WM_SETTINGCHANGE HEX: 001A ; inline add-windows-message -: WM_DEVMODECHANGE HEX: 001B ; inline add-windows-message -: WM_ACTIVATEAPP HEX: 001C ; inline add-windows-message -: WM_FONTCHANGE HEX: 001D ; inline add-windows-message -: WM_TIMECHANGE HEX: 001E ; inline add-windows-message -: WM_CANCELMODE HEX: 001F ; inline add-windows-message -: WM_SETCURSOR HEX: 0020 ; inline add-windows-message -: WM_MOUSEACTIVATE HEX: 0021 ; inline add-windows-message -: WM_CHILDACTIVATE HEX: 0022 ; inline add-windows-message -: WM_QUEUESYNC HEX: 0023 ; inline add-windows-message -: WM_GETMINMAXINFO HEX: 0024 ; inline add-windows-message -: WM_PAINTICON HEX: 0026 ; inline add-windows-message -: WM_ICONERASEBKGND HEX: 0027 ; inline add-windows-message -: WM_NEXTDLGCTL HEX: 0028 ; inline add-windows-message -: WM_SPOOLERSTATUS HEX: 002A ; inline add-windows-message -: WM_DRAWITEM HEX: 002B ; inline add-windows-message -: WM_MEASUREITEM HEX: 002C ; inline add-windows-message -: WM_DELETEITEM HEX: 002D ; inline add-windows-message -: WM_VKEYTOITEM HEX: 002E ; inline add-windows-message -: WM_CHARTOITEM HEX: 002F ; inline add-windows-message -: WM_SETFONT HEX: 0030 ; inline add-windows-message -: WM_GETFONT HEX: 0031 ; inline add-windows-message -: WM_SETHOTKEY HEX: 0032 ; inline add-windows-message -: WM_GETHOTKEY HEX: 0033 ; inline add-windows-message -: WM_QUERYDRAGICON HEX: 0037 ; inline add-windows-message -: WM_COMPAREITEM HEX: 0039 ; inline add-windows-message -: WM_GETOBJECT HEX: 003D ; inline add-windows-message -: WM_COMPACTING HEX: 0041 ; inline add-windows-message -: WM_COMMNOTIFY HEX: 0044 ; inline add-windows-message -: WM_WINDOWPOSCHANGING HEX: 0046 ; inline add-windows-message -: WM_WINDOWPOSCHANGED HEX: 0047 ; inline add-windows-message -: WM_POWER HEX: 0048 ; inline add-windows-message -: WM_COPYDATA HEX: 004A ; inline add-windows-message -: WM_CANCELJOURNAL HEX: 004B ; inline add-windows-message -: WM_NOTIFY HEX: 004E ; inline add-windows-message -: WM_INPUTLANGCHANGEREQUEST HEX: 0050 ; inline add-windows-message -: WM_INPUTLANGCHANGE HEX: 0051 ; inline add-windows-message -: WM_TCARD HEX: 0052 ; inline add-windows-message -: WM_HELP HEX: 0053 ; inline add-windows-message -: WM_USERCHANGED HEX: 0054 ; inline add-windows-message -: WM_NOTIFYFORMAT HEX: 0055 ; inline add-windows-message -: WM_CONTEXTMENU HEX: 007B ; inline add-windows-message -: WM_STYLECHANGING HEX: 007C ; inline add-windows-message -: WM_STYLECHANGED HEX: 007D ; inline add-windows-message -: WM_DISPLAYCHANGE HEX: 007E ; inline add-windows-message -: WM_GETICON HEX: 007F ; inline add-windows-message -: WM_SETICON HEX: 0080 ; inline add-windows-message -: WM_NCCREATE HEX: 0081 ; inline add-windows-message -: WM_NCDESTROY HEX: 0082 ; inline add-windows-message -: WM_NCCALCSIZE HEX: 0083 ; inline add-windows-message -: WM_NCHITTEST HEX: 0084 ; inline add-windows-message -: WM_NCPAINT HEX: 0085 ; inline add-windows-message -: WM_NCACTIVATE HEX: 0086 ; inline add-windows-message -: WM_GETDLGCODE HEX: 0087 ; inline add-windows-message -: WM_SYNCPAINT HEX: 0088 ; inline add-windows-message -: WM_NCMOUSEMOVE HEX: 00A0 ; inline add-windows-message -: WM_NCLBUTTONDOWN HEX: 00A1 ; inline add-windows-message -: WM_NCLBUTTONUP HEX: 00A2 ; inline add-windows-message -: WM_NCLBUTTONDBLCLK HEX: 00A3 ; inline add-windows-message -: WM_NCRBUTTONDOWN HEX: 00A4 ; inline add-windows-message -: WM_NCRBUTTONUP HEX: 00A5 ; inline add-windows-message -: WM_NCRBUTTONDBLCLK HEX: 00A6 ; inline add-windows-message -: WM_NCMBUTTONDOWN HEX: 00A7 ; inline add-windows-message -: WM_NCMBUTTONUP HEX: 00A8 ; inline add-windows-message -: WM_NCMBUTTONDBLCLK HEX: 00A9 ; inline add-windows-message -: WM_NCXBUTTONDOWN HEX: 00AB ; inline add-windows-message -: WM_NCXBUTTONUP HEX: 00AC ; inline add-windows-message -: WM_NCXBUTTONDBLCLK HEX: 00AD ; inline add-windows-message -: WM_NCUAHDRAWCAPTION HEX: 00AE ; inline add-windows-message ! undocumented -: WM_NCUAHDRAWFRAME HEX: 00AF ; inline add-windows-message ! undocumented -: WM_INPUT HEX: 00FF ; inline add-windows-message -: WM_KEYFIRST HEX: 0100 ; inline add-windows-message -: WM_KEYDOWN HEX: 0100 ; inline add-windows-message -: WM_KEYUP HEX: 0101 ; inline add-windows-message -: WM_CHAR HEX: 0102 ; inline add-windows-message -: WM_DEADCHAR HEX: 0103 ; inline add-windows-message -: WM_SYSKEYDOWN HEX: 0104 ; inline add-windows-message -: WM_SYSKEYUP HEX: 0105 ; inline add-windows-message -: WM_SYSCHAR HEX: 0106 ; inline add-windows-message -: WM_SYSDEADCHAR HEX: 0107 ; inline add-windows-message -: WM_UNICHAR HEX: 0109 ; inline add-windows-message -: WM_KEYLAST_NT501 HEX: 0109 ; inline add-windows-message -: UNICODE_NOCHAR HEX: FFFF ; inline add-windows-message -: WM_KEYLAST_PRE501 HEX: 0108 ; inline add-windows-message -: WM_IME_STARTCOMPOSITION HEX: 010D ; inline add-windows-message -: WM_IME_ENDCOMPOSITION HEX: 010E ; inline add-windows-message -: WM_IME_COMPOSITION HEX: 010F ; inline add-windows-message -: WM_IME_KEYLAST HEX: 010F ; inline add-windows-message -: WM_INITDIALOG HEX: 0110 ; inline add-windows-message -: WM_COMMAND HEX: 0111 ; inline add-windows-message -: WM_SYSCOMMAND HEX: 0112 ; inline add-windows-message -: WM_TIMER HEX: 0113 ; inline add-windows-message -: WM_HSCROLL HEX: 0114 ; inline add-windows-message -: WM_VSCROLL HEX: 0115 ; inline add-windows-message -: WM_INITMENU HEX: 0116 ; inline add-windows-message -: WM_INITMENUPOPUP HEX: 0117 ; inline add-windows-message -: WM_MENUSELECT HEX: 011F ; inline add-windows-message -: WM_MENUCHAR HEX: 0120 ; inline add-windows-message -: WM_ENTERIDLE HEX: 0121 ; inline add-windows-message -: WM_MENURBUTTONUP HEX: 0122 ; inline add-windows-message -: WM_MENUDRAG HEX: 0123 ; inline add-windows-message -: WM_MENUGETOBJECT HEX: 0124 ; inline add-windows-message -: WM_UNINITMENUPOPUP HEX: 0125 ; inline add-windows-message -: WM_MENUCOMMAND HEX: 0126 ; inline add-windows-message -: WM_CHANGEUISTATE HEX: 0127 ; inline add-windows-message -: WM_UPDATEUISTATE HEX: 0128 ; inline add-windows-message -: WM_QUERYUISTATE HEX: 0129 ; inline add-windows-message -: WM_CTLCOLORMSGBOX HEX: 0132 ; inline add-windows-message -: WM_CTLCOLOREDIT HEX: 0133 ; inline add-windows-message -: WM_CTLCOLORLISTBOX HEX: 0134 ; inline add-windows-message -: WM_CTLCOLORBTN HEX: 0135 ; inline add-windows-message -: WM_CTLCOLORDLG HEX: 0136 ; inline add-windows-message -: WM_CTLCOLORSCROLLBAR HEX: 0137 ; inline add-windows-message -: WM_CTLCOLORSTATIC HEX: 0138 ; inline add-windows-message -: WM_MOUSEFIRST HEX: 0200 ; inline add-windows-message -: WM_MOUSEMOVE HEX: 0200 ; inline add-windows-message -: WM_LBUTTONDOWN HEX: 0201 ; inline add-windows-message -: WM_LBUTTONUP HEX: 0202 ; inline add-windows-message -: WM_LBUTTONDBLCLK HEX: 0203 ; inline add-windows-message -: WM_RBUTTONDOWN HEX: 0204 ; inline add-windows-message -: WM_RBUTTONUP HEX: 0205 ; inline add-windows-message -: WM_RBUTTONDBLCLK HEX: 0206 ; inline add-windows-message -: WM_MBUTTONDOWN HEX: 0207 ; inline add-windows-message -: WM_MBUTTONUP HEX: 0208 ; inline add-windows-message -: WM_MBUTTONDBLCLK HEX: 0209 ; inline add-windows-message -: WM_MOUSEWHEEL HEX: 020A ; inline add-windows-message -: WM_XBUTTONDOWN HEX: 020B ; inline add-windows-message -: WM_XBUTTONUP HEX: 020C ; inline add-windows-message -: WM_XBUTTONDBLCLK HEX: 020D ; inline add-windows-message -: WM_MOUSELAST_5 HEX: 020D ; inline add-windows-message -: WM_MOUSELAST_4 HEX: 020A ; inline add-windows-message -: WM_MOUSELAST_PRE_4 HEX: 0209 ; inline add-windows-message -: WM_PARENTNOTIFY HEX: 0210 ; inline add-windows-message -: WM_ENTERMENULOOP HEX: 0211 ; inline add-windows-message -: WM_EXITMENULOOP HEX: 0212 ; inline add-windows-message -: WM_NEXTMENU HEX: 0213 ; inline add-windows-message -: WM_SIZING HEX: 0214 ; inline add-windows-message -: WM_CAPTURECHANGED HEX: 0215 ; inline add-windows-message -: WM_MOVING HEX: 0216 ; inline add-windows-message -: WM_POWERBROADCAST HEX: 0218 ; inline add-windows-message -: WM_DEVICECHANGE HEX: 0219 ; inline add-windows-message -: WM_MDICREATE HEX: 0220 ; inline add-windows-message -: WM_MDIDESTROY HEX: 0221 ; inline add-windows-message -: WM_MDIACTIVATE HEX: 0222 ; inline add-windows-message -: WM_MDIRESTORE HEX: 0223 ; inline add-windows-message -: WM_MDINEXT HEX: 0224 ; inline add-windows-message -: WM_MDIMAXIMIZE HEX: 0225 ; inline add-windows-message -: WM_MDITILE HEX: 0226 ; inline add-windows-message -: WM_MDICASCADE HEX: 0227 ; inline add-windows-message -: WM_MDIICONARRANGE HEX: 0228 ; inline add-windows-message -: WM_MDIGETACTIVE HEX: 0229 ; inline add-windows-message -: WM_MDISETMENU HEX: 0230 ; inline add-windows-message -: WM_ENTERSIZEMOVE HEX: 0231 ; inline add-windows-message -: WM_EXITSIZEMOVE HEX: 0232 ; inline add-windows-message -: WM_DROPFILES HEX: 0233 ; inline add-windows-message -: WM_MDIREFRESHMENU HEX: 0234 ; inline add-windows-message -: WM_IME_SETCONTEXT HEX: 0281 ; inline add-windows-message -: WM_IME_NOTIFY HEX: 0282 ; inline add-windows-message -: WM_IME_CONTROL HEX: 0283 ; inline add-windows-message -: WM_IME_COMPOSITIONFULL HEX: 0284 ; inline add-windows-message -: WM_IME_SELECT HEX: 0285 ; inline add-windows-message -: WM_IME_CHAR HEX: 0286 ; inline add-windows-message -: WM_IME_REQUEST HEX: 0288 ; inline add-windows-message -: WM_IME_KEYDOWN HEX: 0290 ; inline add-windows-message -: WM_IME_KEYUP HEX: 0291 ; inline add-windows-message -: WM_MOUSEHOVER HEX: 02A1 ; inline add-windows-message -: WM_MOUSELEAVE HEX: 02A3 ; inline add-windows-message -: WM_NCMOUSEHOVER HEX: 02A0 ; inline add-windows-message -: WM_NCMOUSELEAVE HEX: 02A2 ; inline add-windows-message -: WM_WTSSESSION_CHANGE HEX: 02B1 ; inline add-windows-message -: WM_TABLET_FIRST HEX: 02c0 ; inline add-windows-message -: WM_TABLET_LAST HEX: 02df ; inline add-windows-message -: WM_CUT HEX: 0300 ; inline add-windows-message -: WM_COPY HEX: 0301 ; inline add-windows-message -: WM_PASTE HEX: 0302 ; inline add-windows-message -: WM_CLEAR HEX: 0303 ; inline add-windows-message -: WM_UNDO HEX: 0304 ; inline add-windows-message -: WM_RENDERFORMAT HEX: 0305 ; inline add-windows-message -: WM_RENDERALLFORMATS HEX: 0306 ; inline add-windows-message -: WM_DESTROYCLIPBOARD HEX: 0307 ; inline add-windows-message -: WM_DRAWCLIPBOARD HEX: 0308 ; inline add-windows-message -: WM_PAINTCLIPBOARD HEX: 0309 ; inline add-windows-message -: WM_VSCROLLCLIPBOARD HEX: 030A ; inline add-windows-message -: WM_SIZECLIPBOARD HEX: 030B ; inline add-windows-message -: WM_ASKCBFORMATNAME HEX: 030C ; inline add-windows-message -: WM_CHANGECBCHAIN HEX: 030D ; inline add-windows-message -: WM_HSCROLLCLIPBOARD HEX: 030E ; inline add-windows-message -: WM_QUERYNEWPALETTE HEX: 030F ; inline add-windows-message -: WM_PALETTEISCHANGING HEX: 0310 ; inline add-windows-message -: WM_PALETTECHANGED HEX: 0311 ; inline add-windows-message -: WM_HOTKEY HEX: 0312 ; inline add-windows-message -: WM_PRINT HEX: 0317 ; inline add-windows-message -: WM_PRINTCLIENT HEX: 0318 ; inline add-windows-message -: WM_APPCOMMAND HEX: 0319 ; inline add-windows-message -: WM_THEMECHANGED HEX: 031A ; inline add-windows-message -: WM_HANDHELDFIRST HEX: 0358 ; inline add-windows-message -: WM_HANDHELDLAST HEX: 035F ; inline add-windows-message -: WM_AFXFIRST HEX: 0360 ; inline add-windows-message -: WM_AFXLAST HEX: 037F ; inline add-windows-message -: WM_PENWINFIRST HEX: 0380 ; inline add-windows-message -: WM_PENWINLAST HEX: 038F ; inline add-windows-message -: WM_APP HEX: 8000 ; inline add-windows-message -: WM_USER HEX: 0400 ; inline add-windows-message -: EM_GETSEL HEX: 00B0 ; inline add-windows-message -: EM_SETSEL HEX: 00B1 ; inline add-windows-message -: EM_GETRECT HEX: 00B2 ; inline add-windows-message -: EM_SETRECT HEX: 00B3 ; inline add-windows-message -: EM_SETRECTNP HEX: 00B4 ; inline add-windows-message -: EM_SCROLL HEX: 00B5 ; inline add-windows-message -: EM_LINESCROLL HEX: 00B6 ; inline add-windows-message -: EM_SCROLLCARET HEX: 00B7 ; inline add-windows-message -: EM_GETMODIFY HEX: 00B8 ; inline add-windows-message -: EM_SETMODIFY HEX: 00B9 ; inline add-windows-message -: EM_GETLINECOUNT HEX: 00BA ; inline add-windows-message -: EM_LINEINDEX HEX: 00BB ; inline add-windows-message -: EM_SETHANDLE HEX: 00BC ; inline add-windows-message -: EM_GETHANDLE HEX: 00BD ; inline add-windows-message -: EM_GETTHUMB HEX: 00BE ; inline add-windows-message -: EM_LINELENGTH HEX: 00C1 ; inline add-windows-message -: EM_REPLACESEL HEX: 00C2 ; inline add-windows-message -: EM_GETLINE HEX: 00C4 ; inline add-windows-message -: EM_LIMITTEXT HEX: 00C5 ; inline add-windows-message -: EM_CANUNDO HEX: 00C6 ; inline add-windows-message -: EM_UNDO HEX: 00C7 ; inline add-windows-message -: EM_FMTLINES HEX: 00C8 ; inline add-windows-message -: EM_LINEFROMCHAR HEX: 00C9 ; inline add-windows-message -: EM_SETTABSTOPS HEX: 00CB ; inline add-windows-message -: EM_SETPASSWORDCHAR HEX: 00CC ; inline add-windows-message -: EM_EMPTYUNDOBUFFER HEX: 00CD ; inline add-windows-message -: EM_GETFIRSTVISIBLELINE HEX: 00CE ; inline add-windows-message -: EM_SETREADONLY HEX: 00CF ; inline add-windows-message -: EM_SETWORDBREAKPROC HEX: 00D0 ; inline add-windows-message -: EM_GETWORDBREAKPROC HEX: 00D1 ; inline add-windows-message -: EM_GETPASSWORDCHAR HEX: 00D2 ; inline add-windows-message -: EM_SETMARGINS HEX: 00D3 ; inline add-windows-message -: EM_GETMARGINS HEX: 00D4 ; inline add-windows-message -: EM_SETLIMITTEXT EM_LIMITTEXT ; inline add-windows-message -: EM_GETLIMITTEXT HEX: 00D5 ; inline add-windows-message -: EM_POSFROMCHAR HEX: 00D6 ; inline add-windows-message -: EM_CHARFROMPOS HEX: 00D7 ; inline add-windows-message -: EM_SETIMESTATUS HEX: 00D8 ; inline add-windows-message -: EM_GETIMESTATUS HEX: 00D9 ; inline add-windows-message -: BM_GETCHECK HEX: 00F0 ; inline add-windows-message -: BM_SETCHECK HEX: 00F1 ; inline add-windows-message -: BM_GETSTATE HEX: 00F2 ; inline add-windows-message -: BM_SETSTATE HEX: 00F3 ; inline add-windows-message -: BM_SETSTYLE HEX: 00F4 ; inline add-windows-message -: BM_CLICK HEX: 00F5 ; inline add-windows-message -: BM_GETIMAGE HEX: 00F6 ; inline add-windows-message -: BM_SETIMAGE HEX: 00F7 ; inline add-windows-message -: STM_SETICON HEX: 0170 ; inline add-windows-message -: STM_GETICON HEX: 0171 ; inline add-windows-message -: STM_SETIMAGE HEX: 0172 ; inline add-windows-message -: STM_GETIMAGE HEX: 0173 ; inline add-windows-message -: STM_MSGMAX HEX: 0174 ; inline add-windows-message -: DM_GETDEFID WM_USER ; inline add-windows-message -: DM_SETDEFID WM_USER 1 + ; inline add-windows-message -: DM_REPOSITION WM_USER 2 + ; inline add-windows-message -: LB_ADDSTRING HEX: 0180 ; inline add-windows-message -: LB_INSERTSTRING HEX: 0181 ; inline add-windows-message -: LB_DELETESTRING HEX: 0182 ; inline add-windows-message -: LB_SELITEMRANGEEX HEX: 0183 ; inline add-windows-message -: LB_RESETCONTENT HEX: 0184 ; inline add-windows-message -: LB_SETSEL HEX: 0185 ; inline add-windows-message -: LB_SETCURSEL HEX: 0186 ; inline add-windows-message -: LB_GETSEL HEX: 0187 ; inline add-windows-message -: LB_GETCURSEL HEX: 0188 ; inline add-windows-message -: LB_GETTEXT HEX: 0189 ; inline add-windows-message -: LB_GETTEXTLEN HEX: 018A ; inline add-windows-message -: LB_GETCOUNT HEX: 018B ; inline add-windows-message -: LB_SELECTSTRING HEX: 018C ; inline add-windows-message -: LB_DIR HEX: 018D ; inline add-windows-message -: LB_GETTOPINDEX HEX: 018E ; inline add-windows-message -: LB_FINDSTRING HEX: 018F ; inline add-windows-message -: LB_GETSELCOUNT HEX: 0190 ; inline add-windows-message -: LB_GETSELITEMS HEX: 0191 ; inline add-windows-message -: LB_SETTABSTOPS HEX: 0192 ; inline add-windows-message -: LB_GETHORIZONTALEXTENT HEX: 0193 ; inline add-windows-message -: LB_SETHORIZONTALEXTENT HEX: 0194 ; inline add-windows-message -: LB_SETCOLUMNWIDTH HEX: 0195 ; inline add-windows-message -: LB_ADDFILE HEX: 0196 ; inline add-windows-message -: LB_SETTOPINDEX HEX: 0197 ; inline add-windows-message -: LB_GETITEMRECT HEX: 0198 ; inline add-windows-message -: LB_GETITEMDATA HEX: 0199 ; inline add-windows-message -: LB_SETITEMDATA HEX: 019A ; inline add-windows-message -: LB_SELITEMRANGE HEX: 019B ; inline add-windows-message -: LB_SETANCHORINDEX HEX: 019C ; inline add-windows-message -: LB_GETANCHORINDEX HEX: 019D ; inline add-windows-message -: LB_SETCARETINDEX HEX: 019E ; inline add-windows-message -: LB_GETCARETINDEX HEX: 019F ; inline add-windows-message -: LB_SETITEMHEIGHT HEX: 01A0 ; inline add-windows-message -: LB_GETITEMHEIGHT HEX: 01A1 ; inline add-windows-message -: LB_FINDSTRINGEXACT HEX: 01A2 ; inline add-windows-message -: LB_SETLOCALE HEX: 01A5 ; inline add-windows-message -: LB_GETLOCALE HEX: 01A6 ; inline add-windows-message -: LB_SETCOUNT HEX: 01A7 ; inline add-windows-message -: LB_INITSTORAGE HEX: 01A8 ; inline add-windows-message -: LB_ITEMFROMPOINT HEX: 01A9 ; inline add-windows-message -: LB_MULTIPLEADDSTRING HEX: 01B1 ; inline add-windows-message -: LB_GETLISTBOXINFO HEX: 01B2 ; inline add-windows-message -: LB_MSGMAX_501 HEX: 01B3 ; inline add-windows-message -: LB_MSGMAX_WCE4 HEX: 01B1 ; inline add-windows-message -: LB_MSGMAX_4 HEX: 01B0 ; inline add-windows-message -: LB_MSGMAX_PRE4 HEX: 01A8 ; inline add-windows-message -: CB_GETEDITSEL HEX: 0140 ; inline add-windows-message -: CB_LIMITTEXT HEX: 0141 ; inline add-windows-message -: CB_SETEDITSEL HEX: 0142 ; inline add-windows-message -: CB_ADDSTRING HEX: 0143 ; inline add-windows-message -: CB_DELETESTRING HEX: 0144 ; inline add-windows-message -: CB_DIR HEX: 0145 ; inline add-windows-message -: CB_GETCOUNT HEX: 0146 ; inline add-windows-message -: CB_GETCURSEL HEX: 0147 ; inline add-windows-message -: CB_GETLBTEXT HEX: 0148 ; inline add-windows-message -: CB_GETLBTEXTLEN HEX: 0149 ; inline add-windows-message -: CB_INSERTSTRING HEX: 014A ; inline add-windows-message -: CB_RESETCONTENT HEX: 014B ; inline add-windows-message -: CB_FINDSTRING HEX: 014C ; inline add-windows-message -: CB_SELECTSTRING HEX: 014D ; inline add-windows-message -: CB_SETCURSEL HEX: 014E ; inline add-windows-message -: CB_SHOWDROPDOWN HEX: 014F ; inline add-windows-message -: CB_GETITEMDATA HEX: 0150 ; inline add-windows-message -: CB_SETITEMDATA HEX: 0151 ; inline add-windows-message -: CB_GETDROPPEDCONTROLRECT HEX: 0152 ; inline add-windows-message -: CB_SETITEMHEIGHT HEX: 0153 ; inline add-windows-message -: CB_GETITEMHEIGHT HEX: 0154 ; inline add-windows-message -: CB_SETEXTENDEDUI HEX: 0155 ; inline add-windows-message -: CB_GETEXTENDEDUI HEX: 0156 ; inline add-windows-message -: CB_GETDROPPEDSTATE HEX: 0157 ; inline add-windows-message -: CB_FINDSTRINGEXACT HEX: 0158 ; inline add-windows-message -: CB_SETLOCALE HEX: 0159 ; inline add-windows-message -: CB_GETLOCALE HEX: 015A ; inline add-windows-message -: CB_GETTOPINDEX HEX: 015B ; inline add-windows-message -: CB_SETTOPINDEX HEX: 015C ; inline add-windows-message -: CB_GETHORIZONTALEXTENT HEX: 015d ; inline add-windows-message -: CB_SETHORIZONTALEXTENT HEX: 015e ; inline add-windows-message -: CB_GETDROPPEDWIDTH HEX: 015f ; inline add-windows-message -: CB_SETDROPPEDWIDTH HEX: 0160 ; inline add-windows-message -: CB_INITSTORAGE HEX: 0161 ; inline add-windows-message -: CB_MULTIPLEADDSTRING HEX: 0163 ; inline add-windows-message -: CB_GETCOMBOBOXINFO HEX: 0164 ; inline add-windows-message -: CB_MSGMAX_501 HEX: 0165 ; inline add-windows-message -: CB_MSGMAX_WCE400 HEX: 0163 ; inline add-windows-message -: CB_MSGMAX_400 HEX: 0162 ; inline add-windows-message -: CB_MSGMAX_PRE400 HEX: 015B ; inline add-windows-message -: SBM_SETPOS HEX: 00E0 ; inline add-windows-message -: SBM_GETPOS HEX: 00E1 ; inline add-windows-message -: SBM_SETRANGE HEX: 00E2 ; inline add-windows-message -: SBM_SETRANGEREDRAW HEX: 00E6 ; inline add-windows-message -: SBM_GETRANGE HEX: 00E3 ; inline add-windows-message -: SBM_ENABLE_ARROWS HEX: 00E4 ; inline add-windows-message -: SBM_SETSCROLLINFO HEX: 00E9 ; inline add-windows-message -: SBM_GETSCROLLINFO HEX: 00EA ; inline add-windows-message -: SBM_GETSCROLLBARINFO HEX: 00EB ; inline add-windows-message -: LVM_FIRST HEX: 1000 ; inline add-windows-message ! ListView messages -: TV_FIRST HEX: 1100 ; inline add-windows-message ! TreeView messages -: HDM_FIRST HEX: 1200 ; inline add-windows-message ! Header messages -: TCM_FIRST HEX: 1300 ; inline add-windows-message ! Tab control messages -: PGM_FIRST HEX: 1400 ; inline add-windows-message ! Pager control messages -: ECM_FIRST HEX: 1500 ; inline add-windows-message ! Edit control messages -: BCM_FIRST HEX: 1600 ; inline add-windows-message ! Button control messages -: CBM_FIRST HEX: 1700 ; inline add-windows-message ! Combobox control messages -: CCM_FIRST HEX: 2000 ; inline add-windows-message ! Common control shared messages -: CCM_LAST CCM_FIRST HEX: 0200 + ; inline add-windows-message -: CCM_SETBKCOLOR CCM_FIRST 1 + ; inline add-windows-message -: CCM_SETCOLORSCHEME CCM_FIRST 2 + ; inline add-windows-message -: CCM_GETCOLORSCHEME CCM_FIRST 3 + ; inline add-windows-message -: CCM_GETDROPTARGET CCM_FIRST 4 + ; inline add-windows-message -: CCM_SETUNICODEFORMAT CCM_FIRST 5 + ; inline add-windows-message -: CCM_GETUNICODEFORMAT CCM_FIRST 6 + ; inline add-windows-message -: CCM_SETVERSION CCM_FIRST 7 + ; inline add-windows-message -: CCM_GETVERSION CCM_FIRST 8 + ; inline add-windows-message -: CCM_SETNOTIFYWINDOW CCM_FIRST 9 + ; inline add-windows-message -: CCM_SETWINDOWTHEME CCM_FIRST HEX: b + ; inline add-windows-message -: CCM_DPISCALE CCM_FIRST HEX: c + ; inline add-windows-message -: HDM_GETITEMCOUNT HDM_FIRST 0 + ; inline add-windows-message -: HDM_INSERTITEMA HDM_FIRST 1 + ; inline add-windows-message -: HDM_INSERTITEMW HDM_FIRST 10 + ; inline add-windows-message -: HDM_DELETEITEM HDM_FIRST 2 + ; inline add-windows-message -: HDM_GETITEMA HDM_FIRST 3 + ; inline add-windows-message -: HDM_GETITEMW HDM_FIRST 11 + ; inline add-windows-message -: HDM_SETITEMA HDM_FIRST 4 + ; inline add-windows-message -: HDM_SETITEMW HDM_FIRST 12 + ; inline add-windows-message -: HDM_LAYOUT HDM_FIRST 5 + ; inline add-windows-message -: HDM_HITTEST HDM_FIRST 6 + ; inline add-windows-message -: HDM_GETITEMRECT HDM_FIRST 7 + ; inline add-windows-message -: HDM_SETIMAGELIST HDM_FIRST 8 + ; inline add-windows-message -: HDM_GETIMAGELIST HDM_FIRST 9 + ; inline add-windows-message -: HDM_ORDERTOINDEX HDM_FIRST 15 + ; inline add-windows-message -: HDM_CREATEDRAGIMAGE HDM_FIRST 16 + ; inline add-windows-message -: HDM_GETORDERARRAY HDM_FIRST 17 + ; inline add-windows-message -: HDM_SETORDERARRAY HDM_FIRST 18 + ; inline add-windows-message -: HDM_SETHOTDIVIDER HDM_FIRST 19 + ; inline add-windows-message -: HDM_SETBITMAPMARGIN HDM_FIRST 20 + ; inline add-windows-message -: HDM_GETBITMAPMARGIN HDM_FIRST 21 + ; inline add-windows-message -: HDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: HDM_SETFILTERCHANGETIMEOUT HDM_FIRST 22 + ; inline add-windows-message -: HDM_EDITFILTER HDM_FIRST 23 + ; inline add-windows-message -: HDM_CLEARFILTER HDM_FIRST 24 + ; inline add-windows-message -: TB_ENABLEBUTTON WM_USER 1 + ; inline add-windows-message -: TB_CHECKBUTTON WM_USER 2 + ; inline add-windows-message -: TB_PRESSBUTTON WM_USER 3 + ; inline add-windows-message -: TB_HIDEBUTTON WM_USER 4 + ; inline add-windows-message -: TB_INDETERMINATE WM_USER 5 + ; inline add-windows-message -: TB_MARKBUTTON WM_USER 6 + ; inline add-windows-message -: TB_ISBUTTONENABLED WM_USER 9 + ; inline add-windows-message -: TB_ISBUTTONCHECKED WM_USER 10 + ; inline add-windows-message -: TB_ISBUTTONPRESSED WM_USER 11 + ; inline add-windows-message -: TB_ISBUTTONHIDDEN WM_USER 12 + ; inline add-windows-message -: TB_ISBUTTONINDETERMINATE WM_USER 13 + ; inline add-windows-message -: TB_ISBUTTONHIGHLIGHTED WM_USER 14 + ; inline add-windows-message -: TB_SETSTATE WM_USER 17 + ; inline add-windows-message -: TB_GETSTATE WM_USER 18 + ; inline add-windows-message -: TB_ADDBITMAP WM_USER 19 + ; inline add-windows-message -: TB_ADDBUTTONSA WM_USER 20 + ; inline add-windows-message -: TB_INSERTBUTTONA WM_USER 21 + ; inline add-windows-message -: TB_ADDBUTTONS WM_USER 20 + ; inline add-windows-message -: TB_INSERTBUTTON WM_USER 21 + ; inline add-windows-message -: TB_DELETEBUTTON WM_USER 22 + ; inline add-windows-message -: TB_GETBUTTON WM_USER 23 + ; inline add-windows-message -: TB_BUTTONCOUNT WM_USER 24 + ; inline add-windows-message -: TB_COMMANDTOINDEX WM_USER 25 + ; inline add-windows-message -: TB_SAVERESTOREA WM_USER 26 + ; inline add-windows-message -: TB_SAVERESTOREW WM_USER 76 + ; inline add-windows-message -: TB_CUSTOMIZE WM_USER 27 + ; inline add-windows-message -: TB_ADDSTRINGA WM_USER 28 + ; inline add-windows-message -: TB_ADDSTRINGW WM_USER 77 + ; inline add-windows-message -: TB_GETITEMRECT WM_USER 29 + ; inline add-windows-message -: TB_BUTTONSTRUCTSIZE WM_USER 30 + ; inline add-windows-message -: TB_SETBUTTONSIZE WM_USER 31 + ; inline add-windows-message -: TB_SETBITMAPSIZE WM_USER 32 + ; inline add-windows-message -: TB_AUTOSIZE WM_USER 33 + ; inline add-windows-message -: TB_GETTOOLTIPS WM_USER 35 + ; inline add-windows-message -: TB_SETTOOLTIPS WM_USER 36 + ; inline add-windows-message -: TB_SETPARENT WM_USER 37 + ; inline add-windows-message -: TB_SETROWS WM_USER 39 + ; inline add-windows-message -: TB_GETROWS WM_USER 40 + ; inline add-windows-message -: TB_SETCMDID WM_USER 42 + ; inline add-windows-message -: TB_CHANGEBITMAP WM_USER 43 + ; inline add-windows-message -: TB_GETBITMAP WM_USER 44 + ; inline add-windows-message -: TB_GETBUTTONTEXTA WM_USER 45 + ; inline add-windows-message -: TB_GETBUTTONTEXTW WM_USER 75 + ; inline add-windows-message -: TB_REPLACEBITMAP WM_USER 46 + ; inline add-windows-message -: TB_SETINDENT WM_USER 47 + ; inline add-windows-message -: TB_SETIMAGELIST WM_USER 48 + ; inline add-windows-message -: TB_GETIMAGELIST WM_USER 49 + ; inline add-windows-message -: TB_LOADIMAGES WM_USER 50 + ; inline add-windows-message -: TB_GETRECT WM_USER 51 + ; inline add-windows-message -: TB_SETHOTIMAGELIST WM_USER 52 + ; inline add-windows-message -: TB_GETHOTIMAGELIST WM_USER 53 + ; inline add-windows-message -: TB_SETDISABLEDIMAGELIST WM_USER 54 + ; inline add-windows-message -: TB_GETDISABLEDIMAGELIST WM_USER 55 + ; inline add-windows-message -: TB_SETSTYLE WM_USER 56 + ; inline add-windows-message -: TB_GETSTYLE WM_USER 57 + ; inline add-windows-message -: TB_GETBUTTONSIZE WM_USER 58 + ; inline add-windows-message -: TB_SETBUTTONWIDTH WM_USER 59 + ; inline add-windows-message -: TB_SETMAXTEXTROWS WM_USER 60 + ; inline add-windows-message -: TB_GETTEXTROWS WM_USER 61 + ; inline add-windows-message -: TB_GETOBJECT WM_USER 62 + ; inline add-windows-message -: TB_GETHOTITEM WM_USER 71 + ; inline add-windows-message -: TB_SETHOTITEM WM_USER 72 + ; inline add-windows-message -: TB_SETANCHORHIGHLIGHT WM_USER 73 + ; inline add-windows-message -: TB_GETANCHORHIGHLIGHT WM_USER 74 + ; inline add-windows-message -: TB_MAPACCELERATORA WM_USER 78 + ; inline add-windows-message -: TB_GETINSERTMARK WM_USER 79 + ; inline add-windows-message -: TB_SETINSERTMARK WM_USER 80 + ; inline add-windows-message -: TB_INSERTMARKHITTEST WM_USER 81 + ; inline add-windows-message -: TB_MOVEBUTTON WM_USER 82 + ; inline add-windows-message -: TB_GETMAXSIZE WM_USER 83 + ; inline add-windows-message -: TB_SETEXTENDEDSTYLE WM_USER 84 + ; inline add-windows-message -: TB_GETEXTENDEDSTYLE WM_USER 85 + ; inline add-windows-message -: TB_GETPADDING WM_USER 86 + ; inline add-windows-message -: TB_SETPADDING WM_USER 87 + ; inline add-windows-message -: TB_SETINSERTMARKCOLOR WM_USER 88 + ; inline add-windows-message -: TB_GETINSERTMARKCOLOR WM_USER 89 + ; inline add-windows-message -: TB_SETCOLORSCHEME CCM_SETCOLORSCHEME ; inline add-windows-message -: TB_GETCOLORSCHEME CCM_GETCOLORSCHEME ; inline add-windows-message -: TB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: TB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: TB_MAPACCELERATORW WM_USER 90 + ; inline add-windows-message -: TB_GETBITMAPFLAGS WM_USER 41 + ; inline add-windows-message -: TB_GETBUTTONINFOW WM_USER 63 + ; inline add-windows-message -: TB_SETBUTTONINFOW WM_USER 64 + ; inline add-windows-message -: TB_GETBUTTONINFOA WM_USER 65 + ; inline add-windows-message -: TB_SETBUTTONINFOA WM_USER 66 + ; inline add-windows-message -: TB_INSERTBUTTONW WM_USER 67 + ; inline add-windows-message -: TB_ADDBUTTONSW WM_USER 68 + ; inline add-windows-message -: TB_HITTEST WM_USER 69 + ; inline add-windows-message -: TB_SETDRAWTEXTFLAGS WM_USER 70 + ; inline add-windows-message -: TB_GETSTRINGW WM_USER 91 + ; inline add-windows-message -: TB_GETSTRINGA WM_USER 92 + ; inline add-windows-message -: TB_GETMETRICS WM_USER 101 + ; inline add-windows-message -: TB_SETMETRICS WM_USER 102 + ; inline add-windows-message -: TB_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline add-windows-message -: RB_INSERTBANDA WM_USER 1 + ; inline add-windows-message -: RB_DELETEBAND WM_USER 2 + ; inline add-windows-message -: RB_GETBARINFO WM_USER 3 + ; inline add-windows-message -: RB_SETBARINFO WM_USER 4 + ; inline add-windows-message -: RB_GETBANDINFO WM_USER 5 + ; inline add-windows-message -: RB_SETBANDINFOA WM_USER 6 + ; inline add-windows-message -: RB_SETPARENT WM_USER 7 + ; inline add-windows-message -: RB_HITTEST WM_USER 8 + ; inline add-windows-message -: RB_GETRECT WM_USER 9 + ; inline add-windows-message -: RB_INSERTBANDW WM_USER 10 + ; inline add-windows-message -: RB_SETBANDINFOW WM_USER 11 + ; inline add-windows-message -: RB_GETBANDCOUNT WM_USER 12 + ; inline add-windows-message -: RB_GETROWCOUNT WM_USER 13 + ; inline add-windows-message -: RB_GETROWHEIGHT WM_USER 14 + ; inline add-windows-message -: RB_IDTOINDEX WM_USER 16 + ; inline add-windows-message -: RB_GETTOOLTIPS WM_USER 17 + ; inline add-windows-message -: RB_SETTOOLTIPS WM_USER 18 + ; inline add-windows-message -: RB_SETBKCOLOR WM_USER 19 + ; inline add-windows-message -: RB_GETBKCOLOR WM_USER 20 + ; inline add-windows-message -: RB_SETTEXTCOLOR WM_USER 21 + ; inline add-windows-message -: RB_GETTEXTCOLOR WM_USER 22 + ; inline add-windows-message -: RB_SIZETORECT WM_USER 23 + ; inline add-windows-message -: RB_SETCOLORSCHEME CCM_SETCOLORSCHEME ; inline add-windows-message -: RB_GETCOLORSCHEME CCM_GETCOLORSCHEME ; inline add-windows-message -: RB_BEGINDRAG WM_USER 24 + ; inline add-windows-message -: RB_ENDDRAG WM_USER 25 + ; inline add-windows-message -: RB_DRAGMOVE WM_USER 26 + ; inline add-windows-message -: RB_GETBARHEIGHT WM_USER 27 + ; inline add-windows-message -: RB_GETBANDINFOW WM_USER 28 + ; inline add-windows-message -: RB_GETBANDINFOA WM_USER 29 + ; inline add-windows-message -: RB_MINIMIZEBAND WM_USER 30 + ; inline add-windows-message -: RB_MAXIMIZEBAND WM_USER 31 + ; inline add-windows-message -: RB_GETDROPTARGET CCM_GETDROPTARGET ; inline add-windows-message -: RB_GETBANDBORDERS WM_USER 34 + ; inline add-windows-message -: RB_SHOWBAND WM_USER 35 + ; inline add-windows-message -: RB_SETPALETTE WM_USER 37 + ; inline add-windows-message -: RB_GETPALETTE WM_USER 38 + ; inline add-windows-message -: RB_MOVEBAND WM_USER 39 + ; inline add-windows-message -: RB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: RB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: RB_GETBANDMARGINS WM_USER 40 + ; inline add-windows-message -: RB_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline add-windows-message -: RB_PUSHCHEVRON WM_USER 43 + ; inline add-windows-message -: TTM_ACTIVATE WM_USER 1 + ; inline add-windows-message -: TTM_SETDELAYTIME WM_USER 3 + ; inline add-windows-message -: TTM_ADDTOOLA WM_USER 4 + ; inline add-windows-message -: TTM_ADDTOOLW WM_USER 50 + ; inline add-windows-message -: TTM_DELTOOLA WM_USER 5 + ; inline add-windows-message -: TTM_DELTOOLW WM_USER 51 + ; inline add-windows-message -: TTM_NEWTOOLRECTA WM_USER 6 + ; inline add-windows-message -: TTM_NEWTOOLRECTW WM_USER 52 + ; inline add-windows-message -: TTM_RELAYEVENT WM_USER 7 + ; inline add-windows-message -: TTM_GETTOOLINFOA WM_USER 8 + ; inline add-windows-message -: TTM_GETTOOLINFOW WM_USER 53 + ; inline add-windows-message -: TTM_SETTOOLINFOA WM_USER 9 + ; inline add-windows-message -: TTM_SETTOOLINFOW WM_USER 54 + ; inline add-windows-message -: TTM_HITTESTA WM_USER 10 + ; inline add-windows-message -: TTM_HITTESTW WM_USER 55 + ; inline add-windows-message -: TTM_GETTEXTA WM_USER 11 + ; inline add-windows-message -: TTM_GETTEXTW WM_USER 56 + ; inline add-windows-message -: TTM_UPDATETIPTEXTA WM_USER 12 + ; inline add-windows-message -: TTM_UPDATETIPTEXTW WM_USER 57 + ; inline add-windows-message -: TTM_GETTOOLCOUNT WM_USER 13 + ; inline add-windows-message -: TTM_ENUMTOOLSA WM_USER 14 + ; inline add-windows-message -: TTM_ENUMTOOLSW WM_USER 58 + ; inline add-windows-message -: TTM_GETCURRENTTOOLA WM_USER 15 + ; inline add-windows-message -: TTM_GETCURRENTTOOLW WM_USER 59 + ; inline add-windows-message -: TTM_WINDOWFROMPOINT WM_USER 16 + ; inline add-windows-message -: TTM_TRACKACTIVATE WM_USER 17 + ; inline add-windows-message -: TTM_TRACKPOSITION WM_USER 18 + ; inline add-windows-message -: TTM_SETTIPBKCOLOR WM_USER 19 + ; inline add-windows-message -: TTM_SETTIPTEXTCOLOR WM_USER 20 + ; inline add-windows-message -: TTM_GETDELAYTIME WM_USER 21 + ; inline add-windows-message -: TTM_GETTIPBKCOLOR WM_USER 22 + ; inline add-windows-message -: TTM_GETTIPTEXTCOLOR WM_USER 23 + ; inline add-windows-message -: TTM_SETMAXTIPWIDTH WM_USER 24 + ; inline add-windows-message -: TTM_GETMAXTIPWIDTH WM_USER 25 + ; inline add-windows-message -: TTM_SETMARGIN WM_USER 26 + ; inline add-windows-message -: TTM_GETMARGIN WM_USER 27 + ; inline add-windows-message -: TTM_POP WM_USER 28 + ; inline add-windows-message -: TTM_UPDATE WM_USER 29 + ; inline add-windows-message -: TTM_GETBUBBLESIZE WM_USER 30 + ; inline add-windows-message -: TTM_ADJUSTRECT WM_USER 31 + ; inline add-windows-message -: TTM_SETTITLEA WM_USER 32 + ; inline add-windows-message -: TTM_SETTITLEW WM_USER 33 + ; inline add-windows-message -: TTM_POPUP WM_USER 34 + ; inline add-windows-message -: TTM_GETTITLE WM_USER 35 + ; inline add-windows-message -: TTM_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline add-windows-message -: SB_SETTEXTA WM_USER 1+ ; inline add-windows-message -: SB_SETTEXTW WM_USER 11 + ; inline add-windows-message -: SB_GETTEXTA WM_USER 2 + ; inline add-windows-message -: SB_GETTEXTW WM_USER 13 + ; inline add-windows-message -: SB_GETTEXTLENGTHA WM_USER 3 + ; inline add-windows-message -: SB_GETTEXTLENGTHW WM_USER 12 + ; inline add-windows-message -: SB_SETPARTS WM_USER 4 + ; inline add-windows-message -: SB_GETPARTS WM_USER 6 + ; inline add-windows-message -: SB_GETBORDERS WM_USER 7 + ; inline add-windows-message -: SB_SETMINHEIGHT WM_USER 8 + ; inline add-windows-message -: SB_SIMPLE WM_USER 9 + ; inline add-windows-message -: SB_GETRECT WM_USER 10 + ; inline add-windows-message -: SB_ISSIMPLE WM_USER 14 + ; inline add-windows-message -: SB_SETICON WM_USER 15 + ; inline add-windows-message -: SB_SETTIPTEXTA WM_USER 16 + ; inline add-windows-message -: SB_SETTIPTEXTW WM_USER 17 + ; inline add-windows-message -: SB_GETTIPTEXTA WM_USER 18 + ; inline add-windows-message -: SB_GETTIPTEXTW WM_USER 19 + ; inline add-windows-message -: SB_GETICON WM_USER 20 + ; inline add-windows-message -: SB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: SB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: SB_SETBKCOLOR CCM_SETBKCOLOR ; inline add-windows-message -: SB_SIMPLEID HEX: 00ff ; inline add-windows-message -: TBM_GETPOS WM_USER ; inline add-windows-message -: TBM_GETRANGEMIN WM_USER 1 + ; inline add-windows-message -: TBM_GETRANGEMAX WM_USER 2 + ; inline add-windows-message -: TBM_GETTIC WM_USER 3 + ; inline add-windows-message -: TBM_SETTIC WM_USER 4 + ; inline add-windows-message -: TBM_SETPOS WM_USER 5 + ; inline add-windows-message -: TBM_SETRANGE WM_USER 6 + ; inline add-windows-message -: TBM_SETRANGEMIN WM_USER 7 + ; inline add-windows-message -: TBM_SETRANGEMAX WM_USER 8 + ; inline add-windows-message -: TBM_CLEARTICS WM_USER 9 + ; inline add-windows-message -: TBM_SETSEL WM_USER 10 + ; inline add-windows-message -: TBM_SETSELSTART WM_USER 11 + ; inline add-windows-message -: TBM_SETSELEND WM_USER 12 + ; inline add-windows-message -: TBM_GETPTICS WM_USER 14 + ; inline add-windows-message -: TBM_GETTICPOS WM_USER 15 + ; inline add-windows-message -: TBM_GETNUMTICS WM_USER 16 + ; inline add-windows-message -: TBM_GETSELSTART WM_USER 17 + ; inline add-windows-message -: TBM_GETSELEND WM_USER 18 + ; inline add-windows-message -: TBM_CLEARSEL WM_USER 19 + ; inline add-windows-message -: TBM_SETTICFREQ WM_USER 20 + ; inline add-windows-message -: TBM_SETPAGESIZE WM_USER 21 + ; inline add-windows-message -: TBM_GETPAGESIZE WM_USER 22 + ; inline add-windows-message -: TBM_SETLINESIZE WM_USER 23 + ; inline add-windows-message -: TBM_GETLINESIZE WM_USER 24 + ; inline add-windows-message -: TBM_GETTHUMBRECT WM_USER 25 + ; inline add-windows-message -: TBM_GETCHANNELRECT WM_USER 26 + ; inline add-windows-message -: TBM_SETTHUMBLENGTH WM_USER 27 + ; inline add-windows-message -: TBM_GETTHUMBLENGTH WM_USER 28 + ; inline add-windows-message -: TBM_SETTOOLTIPS WM_USER 29 + ; inline add-windows-message -: TBM_GETTOOLTIPS WM_USER 30 + ; inline add-windows-message -: TBM_SETTIPSIDE WM_USER 31 + ; inline add-windows-message -: TBM_SETBUDDY WM_USER 32 + ; inline add-windows-message -: TBM_GETBUDDY WM_USER 33 + ; inline add-windows-message -: TBM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: TBM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: DL_BEGINDRAG WM_USER 133 + ; inline add-windows-message -: DL_DRAGGING WM_USER 134 + ; inline add-windows-message -: DL_DROPPED WM_USER 135 + ; inline add-windows-message -: DL_CANCELDRAG WM_USER 136 + ; inline add-windows-message -: UDM_SETRANGE WM_USER 101 + ; inline add-windows-message -: UDM_GETRANGE WM_USER 102 + ; inline add-windows-message -: UDM_SETPOS WM_USER 103 + ; inline add-windows-message -: UDM_GETPOS WM_USER 104 + ; inline add-windows-message -: UDM_SETBUDDY WM_USER 105 + ; inline add-windows-message -: UDM_GETBUDDY WM_USER 106 + ; inline add-windows-message -: UDM_SETACCEL WM_USER 107 + ; inline add-windows-message -: UDM_GETACCEL WM_USER 108 + ; inline add-windows-message -: UDM_SETBASE WM_USER 109 + ; inline add-windows-message -: UDM_GETBASE WM_USER 110 + ; inline add-windows-message -: UDM_SETRANGE32 WM_USER 111 + ; inline add-windows-message -: UDM_GETRANGE32 WM_USER 112 + ; inline add-windows-message -: UDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: UDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: UDM_SETPOS32 WM_USER 113 + ; inline add-windows-message -: UDM_GETPOS32 WM_USER 114 + ; inline add-windows-message -: PBM_SETRANGE WM_USER 1 + ; inline add-windows-message -: PBM_SETPOS WM_USER 2 + ; inline add-windows-message -: PBM_DELTAPOS WM_USER 3 + ; inline add-windows-message -: PBM_SETSTEP WM_USER 4 + ; inline add-windows-message -: PBM_STEPIT WM_USER 5 + ; inline add-windows-message -: PBM_SETRANGE32 WM_USER 6 + ; inline add-windows-message -: PBM_GETRANGE WM_USER 7 + ; inline add-windows-message -: PBM_GETPOS WM_USER 8 + ; inline add-windows-message -: PBM_SETBARCOLOR WM_USER 9 + ; inline add-windows-message -: PBM_SETBKCOLOR CCM_SETBKCOLOR ; inline add-windows-message -: HKM_SETHOTKEY WM_USER 1 + ; inline add-windows-message -: HKM_GETHOTKEY WM_USER 2 + ; inline add-windows-message -: HKM_SETRULES WM_USER 3 + ; inline add-windows-message -: LVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: LVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: LVM_GETBKCOLOR LVM_FIRST 0 + ; inline add-windows-message -: LVM_SETBKCOLOR LVM_FIRST 1 + ; inline add-windows-message -: LVM_GETIMAGELIST LVM_FIRST 2 + ; inline add-windows-message -: LVM_SETIMAGELIST LVM_FIRST 3 + ; inline add-windows-message -: LVM_GETITEMCOUNT LVM_FIRST 4 + ; inline add-windows-message -: LVM_GETITEMA LVM_FIRST 5 + ; inline add-windows-message -: LVM_GETITEMW LVM_FIRST 75 + ; inline add-windows-message -: LVM_SETITEMA LVM_FIRST 6 + ; inline add-windows-message -: LVM_SETITEMW LVM_FIRST 76 + ; inline add-windows-message -: LVM_INSERTITEMA LVM_FIRST 7 + ; inline add-windows-message -: LVM_INSERTITEMW LVM_FIRST 77 + ; inline add-windows-message -: LVM_DELETEITEM LVM_FIRST 8 + ; inline add-windows-message -: LVM_DELETEALLITEMS LVM_FIRST 9 + ; inline add-windows-message -: LVM_GETCALLBACKMASK LVM_FIRST 10 + ; inline add-windows-message -: LVM_SETCALLBACKMASK LVM_FIRST 11 + ; inline add-windows-message -: LVM_FINDITEMA LVM_FIRST 13 + ; inline add-windows-message -: LVM_FINDITEMW LVM_FIRST 83 + ; inline add-windows-message -: LVM_GETITEMRECT LVM_FIRST 14 + ; inline add-windows-message -: LVM_SETITEMPOSITION LVM_FIRST 15 + ; inline add-windows-message -: LVM_GETITEMPOSITION LVM_FIRST 16 + ; inline add-windows-message -: LVM_GETSTRINGWIDTHA LVM_FIRST 17 + ; inline add-windows-message -: LVM_GETSTRINGWIDTHW LVM_FIRST 87 + ; inline add-windows-message -: LVM_HITTEST LVM_FIRST 18 + ; inline add-windows-message -: LVM_ENSUREVISIBLE LVM_FIRST 19 + ; inline add-windows-message -: LVM_SCROLL LVM_FIRST 20 + ; inline add-windows-message -: LVM_REDRAWITEMS LVM_FIRST 21 + ; inline add-windows-message -: LVM_ARRANGE LVM_FIRST 22 + ; inline add-windows-message -: LVM_EDITLABELA LVM_FIRST 23 + ; inline add-windows-message -: LVM_EDITLABELW LVM_FIRST 118 + ; inline add-windows-message -: LVM_GETEDITCONTROL LVM_FIRST 24 + ; inline add-windows-message -: LVM_GETCOLUMNA LVM_FIRST 25 + ; inline add-windows-message -: LVM_GETCOLUMNW LVM_FIRST 95 + ; inline add-windows-message -: LVM_SETCOLUMNA LVM_FIRST 26 + ; inline add-windows-message -: LVM_SETCOLUMNW LVM_FIRST 96 + ; inline add-windows-message -: LVM_INSERTCOLUMNA LVM_FIRST 27 + ; inline add-windows-message -: LVM_INSERTCOLUMNW LVM_FIRST 97 + ; inline add-windows-message -: LVM_DELETECOLUMN LVM_FIRST 28 + ; inline add-windows-message -: LVM_GETCOLUMNWIDTH LVM_FIRST 29 + ; inline add-windows-message -: LVM_SETCOLUMNWIDTH LVM_FIRST 30 + ; inline add-windows-message -: LVM_CREATEDRAGIMAGE LVM_FIRST 33 + ; inline add-windows-message -: LVM_GETVIEWRECT LVM_FIRST 34 + ; inline add-windows-message -: LVM_GETTEXTCOLOR LVM_FIRST 35 + ; inline add-windows-message -: LVM_SETTEXTCOLOR LVM_FIRST 36 + ; inline add-windows-message -: LVM_GETTEXTBKCOLOR LVM_FIRST 37 + ; inline add-windows-message -: LVM_SETTEXTBKCOLOR LVM_FIRST 38 + ; inline add-windows-message -: LVM_GETTOPINDEX LVM_FIRST 39 + ; inline add-windows-message -: LVM_GETCOUNTPERPAGE LVM_FIRST 40 + ; inline add-windows-message -: LVM_GETORIGIN LVM_FIRST 41 + ; inline add-windows-message -: LVM_UPDATE LVM_FIRST 42 + ; inline add-windows-message -: LVM_SETITEMSTATE LVM_FIRST 43 + ; inline add-windows-message -: LVM_GETITEMSTATE LVM_FIRST 44 + ; inline add-windows-message -: LVM_GETITEMTEXTA LVM_FIRST 45 + ; inline add-windows-message -: LVM_GETITEMTEXTW LVM_FIRST 115 + ; inline add-windows-message -: LVM_SETITEMTEXTA LVM_FIRST 46 + ; inline add-windows-message -: LVM_SETITEMTEXTW LVM_FIRST 116 + ; inline add-windows-message -: LVM_SETITEMCOUNT LVM_FIRST 47 + ; inline add-windows-message -: LVM_SORTITEMS LVM_FIRST 48 + ; inline add-windows-message -: LVM_SETITEMPOSITION32 LVM_FIRST 49 + ; inline add-windows-message -: LVM_GETSELECTEDCOUNT LVM_FIRST 50 + ; inline add-windows-message -: LVM_GETITEMSPACING LVM_FIRST 51 + ; inline add-windows-message -: LVM_GETISEARCHSTRINGA LVM_FIRST 52 + ; inline add-windows-message -: LVM_GETISEARCHSTRINGW LVM_FIRST 117 + ; inline add-windows-message -: LVM_SETICONSPACING LVM_FIRST 53 + ; inline add-windows-message -: LVM_SETEXTENDEDLISTVIEWSTYLE LVM_FIRST 54 + ; inline add-windows-message -: LVM_GETEXTENDEDLISTVIEWSTYLE LVM_FIRST 55 + ; inline add-windows-message -: LVM_GETSUBITEMRECT LVM_FIRST 56 + ; inline add-windows-message -: LVM_SUBITEMHITTEST LVM_FIRST 57 + ; inline add-windows-message -: LVM_SETCOLUMNORDERARRAY LVM_FIRST 58 + ; inline add-windows-message -: LVM_GETCOLUMNORDERARRAY LVM_FIRST 59 + ; inline add-windows-message -: LVM_SETHOTITEM LVM_FIRST 60 + ; inline add-windows-message -: LVM_GETHOTITEM LVM_FIRST 61 + ; inline add-windows-message -: LVM_SETHOTCURSOR LVM_FIRST 62 + ; inline add-windows-message -: LVM_GETHOTCURSOR LVM_FIRST 63 + ; inline add-windows-message -: LVM_APPROXIMATEVIEWRECT LVM_FIRST 64 + ; inline add-windows-message -: LVM_SETWORKAREAS LVM_FIRST 65 + ; inline add-windows-message -: LVM_GETWORKAREAS LVM_FIRST 70 + ; inline add-windows-message -: LVM_GETNUMBEROFWORKAREAS LVM_FIRST 73 + ; inline add-windows-message -: LVM_GETSELECTIONMARK LVM_FIRST 66 + ; inline add-windows-message -: LVM_SETSELECTIONMARK LVM_FIRST 67 + ; inline add-windows-message -: LVM_SETHOVERTIME LVM_FIRST 71 + ; inline add-windows-message -: LVM_GETHOVERTIME LVM_FIRST 72 + ; inline add-windows-message -: LVM_SETTOOLTIPS LVM_FIRST 74 + ; inline add-windows-message -: LVM_GETTOOLTIPS LVM_FIRST 78 + ; inline add-windows-message -: LVM_SORTITEMSEX LVM_FIRST 81 + ; inline add-windows-message -: LVM_SETBKIMAGEA LVM_FIRST 68 + ; inline add-windows-message -: LVM_SETBKIMAGEW LVM_FIRST 138 + ; inline add-windows-message -: LVM_GETBKIMAGEA LVM_FIRST 69 + ; inline add-windows-message -: LVM_GETBKIMAGEW LVM_FIRST 139 + ; inline add-windows-message -: LVM_SETSELECTEDCOLUMN LVM_FIRST 140 + ; inline add-windows-message -: LVM_SETTILEWIDTH LVM_FIRST 141 + ; inline add-windows-message -: LVM_SETVIEW LVM_FIRST 142 + ; inline add-windows-message -: LVM_GETVIEW LVM_FIRST 143 + ; inline add-windows-message -: LVM_INSERTGROUP LVM_FIRST 145 + ; inline add-windows-message -: LVM_SETGROUPINFO LVM_FIRST 147 + ; inline add-windows-message -: LVM_GETGROUPINFO LVM_FIRST 149 + ; inline add-windows-message -: LVM_REMOVEGROUP LVM_FIRST 150 + ; inline add-windows-message -: LVM_MOVEGROUP LVM_FIRST 151 + ; inline add-windows-message -: LVM_MOVEITEMTOGROUP LVM_FIRST 154 + ; inline add-windows-message -: LVM_SETGROUPMETRICS LVM_FIRST 155 + ; inline add-windows-message -: LVM_GETGROUPMETRICS LVM_FIRST 156 + ; inline add-windows-message -: LVM_ENABLEGROUPVIEW LVM_FIRST 157 + ; inline add-windows-message -: LVM_SORTGROUPS LVM_FIRST 158 + ; inline add-windows-message -: LVM_INSERTGROUPSORTED LVM_FIRST 159 + ; inline add-windows-message -: LVM_REMOVEALLGROUPS LVM_FIRST 160 + ; inline add-windows-message -: LVM_HASGROUP LVM_FIRST 161 + ; inline add-windows-message -: LVM_SETTILEVIEWINFO LVM_FIRST 162 + ; inline add-windows-message -: LVM_GETTILEVIEWINFO LVM_FIRST 163 + ; inline add-windows-message -: LVM_SETTILEINFO LVM_FIRST 164 + ; inline add-windows-message -: LVM_GETTILEINFO LVM_FIRST 165 + ; inline add-windows-message -: LVM_SETINSERTMARK LVM_FIRST 166 + ; inline add-windows-message -: LVM_GETINSERTMARK LVM_FIRST 167 + ; inline add-windows-message -: LVM_INSERTMARKHITTEST LVM_FIRST 168 + ; inline add-windows-message -: LVM_GETINSERTMARKRECT LVM_FIRST 169 + ; inline add-windows-message -: LVM_SETINSERTMARKCOLOR LVM_FIRST 170 + ; inline add-windows-message -: LVM_GETINSERTMARKCOLOR LVM_FIRST 171 + ; inline add-windows-message -: LVM_SETINFOTIP LVM_FIRST 173 + ; inline add-windows-message -: LVM_GETSELECTEDCOLUMN LVM_FIRST 174 + ; inline add-windows-message -: LVM_ISGROUPVIEWENABLED LVM_FIRST 175 + ; inline add-windows-message -: LVM_GETOUTLINECOLOR LVM_FIRST 176 + ; inline add-windows-message -: LVM_SETOUTLINECOLOR LVM_FIRST 177 + ; inline add-windows-message -: LVM_CANCELEDITLABEL LVM_FIRST 179 + ; inline add-windows-message -: LVM_MAPINDEXTOID LVM_FIRST 180 + ; inline add-windows-message -: LVM_MAPIDTOINDEX LVM_FIRST 181 + ; inline add-windows-message -: TVM_INSERTITEMA TV_FIRST 0 + ; inline add-windows-message -: TVM_INSERTITEMW TV_FIRST 50 + ; inline add-windows-message -: TVM_DELETEITEM TV_FIRST 1 + ; inline add-windows-message -: TVM_EXPAND TV_FIRST 2 + ; inline add-windows-message -: TVM_GETITEMRECT TV_FIRST 4 + ; inline add-windows-message -: TVM_GETCOUNT TV_FIRST 5 + ; inline add-windows-message -: TVM_GETINDENT TV_FIRST 6 + ; inline add-windows-message -: TVM_SETINDENT TV_FIRST 7 + ; inline add-windows-message -: TVM_GETIMAGELIST TV_FIRST 8 + ; inline add-windows-message -: TVM_SETIMAGELIST TV_FIRST 9 + ; inline add-windows-message -: TVM_GETNEXTITEM TV_FIRST 10 + ; inline add-windows-message -: TVM_SELECTITEM TV_FIRST 11 + ; inline add-windows-message -: TVM_GETITEMA TV_FIRST 12 + ; inline add-windows-message -: TVM_GETITEMW TV_FIRST 62 + ; inline add-windows-message -: TVM_SETITEMA TV_FIRST 13 + ; inline add-windows-message -: TVM_SETITEMW TV_FIRST 63 + ; inline add-windows-message -: TVM_EDITLABELA TV_FIRST 14 + ; inline add-windows-message -: TVM_EDITLABELW TV_FIRST 65 + ; inline add-windows-message -: TVM_GETEDITCONTROL TV_FIRST 15 + ; inline add-windows-message -: TVM_GETVISIBLECOUNT TV_FIRST 16 + ; inline add-windows-message -: TVM_HITTEST TV_FIRST 17 + ; inline add-windows-message -: TVM_CREATEDRAGIMAGE TV_FIRST 18 + ; inline add-windows-message -: TVM_SORTCHILDREN TV_FIRST 19 + ; inline add-windows-message -: TVM_ENSUREVISIBLE TV_FIRST 20 + ; inline add-windows-message -: TVM_SORTCHILDRENCB TV_FIRST 21 + ; inline add-windows-message -: TVM_ENDEDITLABELNOW TV_FIRST 22 + ; inline add-windows-message -: TVM_GETISEARCHSTRINGA TV_FIRST 23 + ; inline add-windows-message -: TVM_GETISEARCHSTRINGW TV_FIRST 64 + ; inline add-windows-message -: TVM_SETTOOLTIPS TV_FIRST 24 + ; inline add-windows-message -: TVM_GETTOOLTIPS TV_FIRST 25 + ; inline add-windows-message -: TVM_SETINSERTMARK TV_FIRST 26 + ; inline add-windows-message -: TVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: TVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: TVM_SETITEMHEIGHT TV_FIRST 27 + ; inline add-windows-message -: TVM_GETITEMHEIGHT TV_FIRST 28 + ; inline add-windows-message -: TVM_SETBKCOLOR TV_FIRST 29 + ; inline add-windows-message -: TVM_SETTEXTCOLOR TV_FIRST 30 + ; inline add-windows-message -: TVM_GETBKCOLOR TV_FIRST 31 + ; inline add-windows-message -: TVM_GETTEXTCOLOR TV_FIRST 32 + ; inline add-windows-message -: TVM_SETSCROLLTIME TV_FIRST 33 + ; inline add-windows-message -: TVM_GETSCROLLTIME TV_FIRST 34 + ; inline add-windows-message -: TVM_SETINSERTMARKCOLOR TV_FIRST 37 + ; inline add-windows-message -: TVM_GETINSERTMARKCOLOR TV_FIRST 38 + ; inline add-windows-message -: TVM_GETITEMSTATE TV_FIRST 39 + ; inline add-windows-message -: TVM_SETLINECOLOR TV_FIRST 40 + ; inline add-windows-message -: TVM_GETLINECOLOR TV_FIRST 41 + ; inline add-windows-message -: TVM_MAPACCIDTOHTREEITEM TV_FIRST 42 + ; inline add-windows-message -: TVM_MAPHTREEITEMTOACCID TV_FIRST 43 + ; inline add-windows-message -: CBEM_INSERTITEMA WM_USER 1 + ; inline add-windows-message -: CBEM_SETIMAGELIST WM_USER 2 + ; inline add-windows-message -: CBEM_GETIMAGELIST WM_USER 3 + ; inline add-windows-message -: CBEM_GETITEMA WM_USER 4 + ; inline add-windows-message -: CBEM_SETITEMA WM_USER 5 + ; inline add-windows-message -: CBEM_DELETEITEM CB_DELETESTRING ; inline add-windows-message -: CBEM_GETCOMBOCONTROL WM_USER 6 + ; inline add-windows-message -: CBEM_GETEDITCONTROL WM_USER 7 + ; inline add-windows-message -: CBEM_SETEXTENDEDSTYLE WM_USER 14 + ; inline add-windows-message -: CBEM_GETEXTENDEDSTYLE WM_USER 9 + ; inline add-windows-message -: CBEM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: CBEM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: CBEM_SETEXSTYLE WM_USER 8 + ; inline add-windows-message -: CBEM_GETEXSTYLE WM_USER 9 + ; inline add-windows-message -: CBEM_HASEDITCHANGED WM_USER 10 + ; inline add-windows-message -: CBEM_INSERTITEMW WM_USER 11 + ; inline add-windows-message -: CBEM_SETITEMW WM_USER 12 + ; inline add-windows-message -: CBEM_GETITEMW WM_USER 13 + ; inline add-windows-message -: TCM_GETIMAGELIST TCM_FIRST 2 + ; inline add-windows-message -: TCM_SETIMAGELIST TCM_FIRST 3 + ; inline add-windows-message -: TCM_GETITEMCOUNT TCM_FIRST 4 + ; inline add-windows-message -: TCM_GETITEMA TCM_FIRST 5 + ; inline add-windows-message -: TCM_GETITEMW TCM_FIRST 60 + ; inline add-windows-message -: TCM_SETITEMA TCM_FIRST 6 + ; inline add-windows-message -: TCM_SETITEMW TCM_FIRST 61 + ; inline add-windows-message -: TCM_INSERTITEMA TCM_FIRST 7 + ; inline add-windows-message -: TCM_INSERTITEMW TCM_FIRST 62 + ; inline add-windows-message -: TCM_DELETEITEM TCM_FIRST 8 + ; inline add-windows-message -: TCM_DELETEALLITEMS TCM_FIRST 9 + ; inline add-windows-message -: TCM_GETITEMRECT TCM_FIRST 10 + ; inline add-windows-message -: TCM_GETCURSEL TCM_FIRST 11 + ; inline add-windows-message -: TCM_SETCURSEL TCM_FIRST 12 + ; inline add-windows-message -: TCM_HITTEST TCM_FIRST 13 + ; inline add-windows-message -: TCM_SETITEMEXTRA TCM_FIRST 14 + ; inline add-windows-message -: TCM_ADJUSTRECT TCM_FIRST 40 + ; inline add-windows-message -: TCM_SETITEMSIZE TCM_FIRST 41 + ; inline add-windows-message -: TCM_REMOVEIMAGE TCM_FIRST 42 + ; inline add-windows-message -: TCM_SETPADDING TCM_FIRST 43 + ; inline add-windows-message -: TCM_GETROWCOUNT TCM_FIRST 44 + ; inline add-windows-message -: TCM_GETTOOLTIPS TCM_FIRST 45 + ; inline add-windows-message -: TCM_SETTOOLTIPS TCM_FIRST 46 + ; inline add-windows-message -: TCM_GETCURFOCUS TCM_FIRST 47 + ; inline add-windows-message -: TCM_SETCURFOCUS TCM_FIRST 48 + ; inline add-windows-message -: TCM_SETMINTABWIDTH TCM_FIRST 49 + ; inline add-windows-message -: TCM_DESELECTALL TCM_FIRST 50 + ; inline add-windows-message -: TCM_HIGHLIGHTITEM TCM_FIRST 51 + ; inline add-windows-message -: TCM_SETEXTENDEDSTYLE TCM_FIRST 52 + ; inline add-windows-message -: TCM_GETEXTENDEDSTYLE TCM_FIRST 53 + ; inline add-windows-message -: TCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: TCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: ACM_OPENA WM_USER 100 + ; inline add-windows-message -: ACM_OPENW WM_USER 103 + ; inline add-windows-message -: ACM_PLAY WM_USER 101 + ; inline add-windows-message -: ACM_STOP WM_USER 102 + ; inline add-windows-message -: MCM_FIRST HEX: 1000 ; inline add-windows-message -: MCM_GETCURSEL MCM_FIRST 1 + ; inline add-windows-message -: MCM_SETCURSEL MCM_FIRST 2 + ; inline add-windows-message -: MCM_GETMAXSELCOUNT MCM_FIRST 3 + ; inline add-windows-message -: MCM_SETMAXSELCOUNT MCM_FIRST 4 + ; inline add-windows-message -: MCM_GETSELRANGE MCM_FIRST 5 + ; inline add-windows-message -: MCM_SETSELRANGE MCM_FIRST 6 + ; inline add-windows-message -: MCM_GETMONTHRANGE MCM_FIRST 7 + ; inline add-windows-message -: MCM_SETDAYSTATE MCM_FIRST 8 + ; inline add-windows-message -: MCM_GETMINREQRECT MCM_FIRST 9 + ; inline add-windows-message -: MCM_SETCOLOR MCM_FIRST 10 + ; inline add-windows-message -: MCM_GETCOLOR MCM_FIRST 11 + ; inline add-windows-message -: MCM_SETTODAY MCM_FIRST 12 + ; inline add-windows-message -: MCM_GETTODAY MCM_FIRST 13 + ; inline add-windows-message -: MCM_HITTEST MCM_FIRST 14 + ; inline add-windows-message -: MCM_SETFIRSTDAYOFWEEK MCM_FIRST 15 + ; inline add-windows-message -: MCM_GETFIRSTDAYOFWEEK MCM_FIRST 16 + ; inline add-windows-message -: MCM_GETRANGE MCM_FIRST 17 + ; inline add-windows-message -: MCM_SETRANGE MCM_FIRST 18 + ; inline add-windows-message -: MCM_GETMONTHDELTA MCM_FIRST 19 + ; inline add-windows-message -: MCM_SETMONTHDELTA MCM_FIRST 20 + ; inline add-windows-message -: MCM_GETMAXTODAYWIDTH MCM_FIRST 21 + ; inline add-windows-message -: MCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline add-windows-message -: MCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline add-windows-message -: DTM_FIRST HEX: 1000 ; inline add-windows-message -: DTM_GETSYSTEMTIME DTM_FIRST 1 + ; inline add-windows-message -: DTM_SETSYSTEMTIME DTM_FIRST 2 + ; inline add-windows-message -: DTM_GETRANGE DTM_FIRST 3 + ; inline add-windows-message -: DTM_SETRANGE DTM_FIRST 4 + ; inline add-windows-message -: DTM_SETFORMATA DTM_FIRST 5 + ; inline add-windows-message -: DTM_SETFORMATW DTM_FIRST 50 + ; inline add-windows-message -: DTM_SETMCCOLOR DTM_FIRST 6 + ; inline add-windows-message -: DTM_GETMCCOLOR DTM_FIRST 7 + ; inline add-windows-message -: DTM_GETMONTHCAL DTM_FIRST 8 + ; inline add-windows-message -: DTM_SETMCFONT DTM_FIRST 9 + ; inline add-windows-message -: DTM_GETMCFONT DTM_FIRST 10 + ; inline add-windows-message -: PGM_SETCHILD PGM_FIRST 1 + ; inline add-windows-message -: PGM_RECALCSIZE PGM_FIRST 2 + ; inline add-windows-message -: PGM_FORWARDMOUSE PGM_FIRST 3 + ; inline add-windows-message -: PGM_SETBKCOLOR PGM_FIRST 4 + ; inline add-windows-message -: PGM_GETBKCOLOR PGM_FIRST 5 + ; inline add-windows-message -: PGM_SETBORDER PGM_FIRST 6 + ; inline add-windows-message -: PGM_GETBORDER PGM_FIRST 7 + ; inline add-windows-message -: PGM_SETPOS PGM_FIRST 8 + ; inline add-windows-message -: PGM_GETPOS PGM_FIRST 9 + ; inline add-windows-message -: PGM_SETBUTTONSIZE PGM_FIRST 10 + ; inline add-windows-message -: PGM_GETBUTTONSIZE PGM_FIRST 11 + ; inline add-windows-message -: PGM_GETBUTTONSTATE PGM_FIRST 12 + ; inline add-windows-message -: PGM_GETDROPTARGET CCM_GETDROPTARGET ; inline add-windows-message -: BCM_GETIDEALSIZE BCM_FIRST 1 + ; inline add-windows-message -: BCM_SETIMAGELIST BCM_FIRST 2 + ; inline add-windows-message -: BCM_GETIMAGELIST BCM_FIRST 3 + ; inline add-windows-message -: BCM_SETTEXTMARGIN BCM_FIRST 4 + ; inline add-windows-message -: BCM_GETTEXTMARGIN BCM_FIRST 5 + ; inline add-windows-message -: EM_SETCUEBANNER ECM_FIRST 1 + ; inline add-windows-message -: EM_GETCUEBANNER ECM_FIRST 2 + ; inline add-windows-message -: EM_SHOWBALLOONTIP ECM_FIRST 3 + ; inline add-windows-message -: EM_HIDEBALLOONTIP ECM_FIRST 4 + ; inline add-windows-message -: CB_SETMINVISIBLE CBM_FIRST 1 + ; inline add-windows-message -: CB_GETMINVISIBLE CBM_FIRST 2 + ; inline add-windows-message -: LM_HITTEST WM_USER HEX: 0300 + ; inline add-windows-message -: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline add-windows-message -: LM_SETITEM WM_USER HEX: 0302 + ; inline add-windows-message -: LM_GETITEM WM_USER HEX: 0303 + ; inline add-windows-message +: WM_NULL HEX: 0000 ; inline +: WM_CREATE HEX: 0001 ; inline +: WM_DESTROY HEX: 0002 ; inline +: WM_MOVE HEX: 0003 ; inline +: WM_SIZE HEX: 0005 ; inline +: WM_ACTIVATE HEX: 0006 ; inline +: WM_SETFOCUS HEX: 0007 ; inline +: WM_KILLFOCUS HEX: 0008 ; inline +: WM_ENABLE HEX: 000A ; inline +: WM_SETREDRAW HEX: 000B ; inline +: WM_SETTEXT HEX: 000C ; inline +: WM_GETTEXT HEX: 000D ; inline +: WM_GETTEXTLENGTH HEX: 000E ; inline +: WM_PAINT HEX: 000F ; inline +: WM_CLOSE HEX: 0010 ; inline +: WM_QUERYENDSESSION HEX: 0011 ; inline +: WM_QUERYOPEN HEX: 0013 ; inline +: WM_ENDSESSION HEX: 0016 ; inline +: WM_QUIT HEX: 0012 ; inline +: WM_ERASEBKGND HEX: 0014 ; inline +: WM_SYSCOLORCHANGE HEX: 0015 ; inline +: WM_SHOWWINDOW HEX: 0018 ; inline +: WM_WININICHANGE HEX: 001A ; inline +: WM_SETTINGCHANGE HEX: 001A ; inline +: WM_DEVMODECHANGE HEX: 001B ; inline +: WM_ACTIVATEAPP HEX: 001C ; inline +: WM_FONTCHANGE HEX: 001D ; inline +: WM_TIMECHANGE HEX: 001E ; inline +: WM_CANCELMODE HEX: 001F ; inline +: WM_SETCURSOR HEX: 0020 ; inline +: WM_MOUSEACTIVATE HEX: 0021 ; inline +: WM_CHILDACTIVATE HEX: 0022 ; inline +: WM_QUEUESYNC HEX: 0023 ; inline +: WM_GETMINMAXINFO HEX: 0024 ; inline +: WM_PAINTICON HEX: 0026 ; inline +: WM_ICONERASEBKGND HEX: 0027 ; inline +: WM_NEXTDLGCTL HEX: 0028 ; inline +: WM_SPOOLERSTATUS HEX: 002A ; inline +: WM_DRAWITEM HEX: 002B ; inline +: WM_MEASUREITEM HEX: 002C ; inline +: WM_DELETEITEM HEX: 002D ; inline +: WM_VKEYTOITEM HEX: 002E ; inline +: WM_CHARTOITEM HEX: 002F ; inline +: WM_SETFONT HEX: 0030 ; inline +: WM_GETFONT HEX: 0031 ; inline +: WM_SETHOTKEY HEX: 0032 ; inline +: WM_GETHOTKEY HEX: 0033 ; inline +: WM_QUERYDRAGICON HEX: 0037 ; inline +: WM_COMPAREITEM HEX: 0039 ; inline +: WM_GETOBJECT HEX: 003D ; inline +: WM_COMPACTING HEX: 0041 ; inline +: WM_COMMNOTIFY HEX: 0044 ; inline +: WM_WINDOWPOSCHANGING HEX: 0046 ; inline +: WM_WINDOWPOSCHANGED HEX: 0047 ; inline +: WM_POWER HEX: 0048 ; inline +: WM_COPYDATA HEX: 004A ; inline +: WM_CANCELJOURNAL HEX: 004B ; inline +: WM_NOTIFY HEX: 004E ; inline +: WM_INPUTLANGCHANGEREQUEST HEX: 0050 ; inline +: WM_INPUTLANGCHANGE HEX: 0051 ; inline +: WM_TCARD HEX: 0052 ; inline +: WM_HELP HEX: 0053 ; inline +: WM_USERCHANGED HEX: 0054 ; inline +: WM_NOTIFYFORMAT HEX: 0055 ; inline +: WM_CONTEXTMENU HEX: 007B ; inline +: WM_STYLECHANGING HEX: 007C ; inline +: WM_STYLECHANGED HEX: 007D ; inline +: WM_DISPLAYCHANGE HEX: 007E ; inline +: WM_GETICON HEX: 007F ; inline +: WM_SETICON HEX: 0080 ; inline +: WM_NCCREATE HEX: 0081 ; inline +: WM_NCDESTROY HEX: 0082 ; inline +: WM_NCCALCSIZE HEX: 0083 ; inline +: WM_NCHITTEST HEX: 0084 ; inline +: WM_NCPAINT HEX: 0085 ; inline +: WM_NCACTIVATE HEX: 0086 ; inline +: WM_GETDLGCODE HEX: 0087 ; inline +: WM_SYNCPAINT HEX: 0088 ; inline +: WM_NCMOUSEMOVE HEX: 00A0 ; inline +: WM_NCLBUTTONDOWN HEX: 00A1 ; inline +: WM_NCLBUTTONUP HEX: 00A2 ; inline +: WM_NCLBUTTONDBLCLK HEX: 00A3 ; inline +: WM_NCRBUTTONDOWN HEX: 00A4 ; inline +: WM_NCRBUTTONUP HEX: 00A5 ; inline +: WM_NCRBUTTONDBLCLK HEX: 00A6 ; inline +: WM_NCMBUTTONDOWN HEX: 00A7 ; inline +: WM_NCMBUTTONUP HEX: 00A8 ; inline +: WM_NCMBUTTONDBLCLK HEX: 00A9 ; inline +: WM_NCXBUTTONDOWN HEX: 00AB ; inline +: WM_NCXBUTTONUP HEX: 00AC ; inline +: WM_NCXBUTTONDBLCLK HEX: 00AD ; inline +: WM_NCUAHDRAWCAPTION HEX: 00AE ; inline ! undocumented +: WM_NCUAHDRAWFRAME HEX: 00AF ; inline ! undocumented +: WM_INPUT HEX: 00FF ; inline +: WM_KEYFIRST HEX: 0100 ; inline +: WM_KEYDOWN HEX: 0100 ; inline +: WM_KEYUP HEX: 0101 ; inline +: WM_CHAR HEX: 0102 ; inline +: WM_DEADCHAR HEX: 0103 ; inline +: WM_SYSKEYDOWN HEX: 0104 ; inline +: WM_SYSKEYUP HEX: 0105 ; inline +: WM_SYSCHAR HEX: 0106 ; inline +: WM_SYSDEADCHAR HEX: 0107 ; inline +: WM_UNICHAR HEX: 0109 ; inline +: WM_KEYLAST_NT501 HEX: 0109 ; inline +: UNICODE_NOCHAR HEX: FFFF ; inline +: WM_KEYLAST_PRE501 HEX: 0108 ; inline +: WM_IME_STARTCOMPOSITION HEX: 010D ; inline +: WM_IME_ENDCOMPOSITION HEX: 010E ; inline +: WM_IME_COMPOSITION HEX: 010F ; inline +: WM_IME_KEYLAST HEX: 010F ; inline +: WM_INITDIALOG HEX: 0110 ; inline +: WM_COMMAND HEX: 0111 ; inline +: WM_SYSCOMMAND HEX: 0112 ; inline +: WM_TIMER HEX: 0113 ; inline +: WM_HSCROLL HEX: 0114 ; inline +: WM_VSCROLL HEX: 0115 ; inline +: WM_INITMENU HEX: 0116 ; inline +: WM_INITMENUPOPUP HEX: 0117 ; inline +: WM_MENUSELECT HEX: 011F ; inline +: WM_MENUCHAR HEX: 0120 ; inline +: WM_ENTERIDLE HEX: 0121 ; inline +: WM_MENURBUTTONUP HEX: 0122 ; inline +: WM_MENUDRAG HEX: 0123 ; inline +: WM_MENUGETOBJECT HEX: 0124 ; inline +: WM_UNINITMENUPOPUP HEX: 0125 ; inline +: WM_MENUCOMMAND HEX: 0126 ; inline +: WM_CHANGEUISTATE HEX: 0127 ; inline +: WM_UPDATEUISTATE HEX: 0128 ; inline +: WM_QUERYUISTATE HEX: 0129 ; inline +: WM_CTLCOLORMSGBOX HEX: 0132 ; inline +: WM_CTLCOLOREDIT HEX: 0133 ; inline +: WM_CTLCOLORLISTBOX HEX: 0134 ; inline +: WM_CTLCOLORBTN HEX: 0135 ; inline +: WM_CTLCOLORDLG HEX: 0136 ; inline +: WM_CTLCOLORSCROLLBAR HEX: 0137 ; inline +: WM_CTLCOLORSTATIC HEX: 0138 ; inline +: WM_MOUSEFIRST HEX: 0200 ; inline +: WM_MOUSEMOVE HEX: 0200 ; inline +: WM_LBUTTONDOWN HEX: 0201 ; inline +: WM_LBUTTONUP HEX: 0202 ; inline +: WM_LBUTTONDBLCLK HEX: 0203 ; inline +: WM_RBUTTONDOWN HEX: 0204 ; inline +: WM_RBUTTONUP HEX: 0205 ; inline +: WM_RBUTTONDBLCLK HEX: 0206 ; inline +: WM_MBUTTONDOWN HEX: 0207 ; inline +: WM_MBUTTONUP HEX: 0208 ; inline +: WM_MBUTTONDBLCLK HEX: 0209 ; inline +: WM_MOUSEWHEEL HEX: 020A ; inline +: WM_XBUTTONDOWN HEX: 020B ; inline +: WM_XBUTTONUP HEX: 020C ; inline +: WM_XBUTTONDBLCLK HEX: 020D ; inline +: WM_MOUSELAST_5 HEX: 020D ; inline +: WM_MOUSELAST_4 HEX: 020A ; inline +: WM_MOUSELAST_PRE_4 HEX: 0209 ; inline +: WM_PARENTNOTIFY HEX: 0210 ; inline +: WM_ENTERMENULOOP HEX: 0211 ; inline +: WM_EXITMENULOOP HEX: 0212 ; inline +: WM_NEXTMENU HEX: 0213 ; inline +: WM_SIZING HEX: 0214 ; inline +: WM_CAPTURECHANGED HEX: 0215 ; inline +: WM_MOVING HEX: 0216 ; inline +: WM_POWERBROADCAST HEX: 0218 ; inline +: WM_DEVICECHANGE HEX: 0219 ; inline +: WM_MDICREATE HEX: 0220 ; inline +: WM_MDIDESTROY HEX: 0221 ; inline +: WM_MDIACTIVATE HEX: 0222 ; inline +: WM_MDIRESTORE HEX: 0223 ; inline +: WM_MDINEXT HEX: 0224 ; inline +: WM_MDIMAXIMIZE HEX: 0225 ; inline +: WM_MDITILE HEX: 0226 ; inline +: WM_MDICASCADE HEX: 0227 ; inline +: WM_MDIICONARRANGE HEX: 0228 ; inline +: WM_MDIGETACTIVE HEX: 0229 ; inline +: WM_MDISETMENU HEX: 0230 ; inline +: WM_ENTERSIZEMOVE HEX: 0231 ; inline +: WM_EXITSIZEMOVE HEX: 0232 ; inline +: WM_DROPFILES HEX: 0233 ; inline +: WM_MDIREFRESHMENU HEX: 0234 ; inline +: WM_IME_SETCONTEXT HEX: 0281 ; inline +: WM_IME_NOTIFY HEX: 0282 ; inline +: WM_IME_CONTROL HEX: 0283 ; inline +: WM_IME_COMPOSITIONFULL HEX: 0284 ; inline +: WM_IME_SELECT HEX: 0285 ; inline +: WM_IME_CHAR HEX: 0286 ; inline +: WM_IME_REQUEST HEX: 0288 ; inline +: WM_IME_KEYDOWN HEX: 0290 ; inline +: WM_IME_KEYUP HEX: 0291 ; inline +: WM_MOUSEHOVER HEX: 02A1 ; inline +: WM_MOUSELEAVE HEX: 02A3 ; inline +: WM_NCMOUSEHOVER HEX: 02A0 ; inline +: WM_NCMOUSELEAVE HEX: 02A2 ; inline +: WM_WTSSESSION_CHANGE HEX: 02B1 ; inline +: WM_TABLET_FIRST HEX: 02c0 ; inline +: WM_TABLET_LAST HEX: 02df ; inline +: WM_CUT HEX: 0300 ; inline +: WM_COPY HEX: 0301 ; inline +: WM_PASTE HEX: 0302 ; inline +: WM_CLEAR HEX: 0303 ; inline +: WM_UNDO HEX: 0304 ; inline +: WM_RENDERFORMAT HEX: 0305 ; inline +: WM_RENDERALLFORMATS HEX: 0306 ; inline +: WM_DESTROYCLIPBOARD HEX: 0307 ; inline +: WM_DRAWCLIPBOARD HEX: 0308 ; inline +: WM_PAINTCLIPBOARD HEX: 0309 ; inline +: WM_VSCROLLCLIPBOARD HEX: 030A ; inline +: WM_SIZECLIPBOARD HEX: 030B ; inline +: WM_ASKCBFORMATNAME HEX: 030C ; inline +: WM_CHANGECBCHAIN HEX: 030D ; inline +: WM_HSCROLLCLIPBOARD HEX: 030E ; inline +: WM_QUERYNEWPALETTE HEX: 030F ; inline +: WM_PALETTEISCHANGING HEX: 0310 ; inline +: WM_PALETTECHANGED HEX: 0311 ; inline +: WM_HOTKEY HEX: 0312 ; inline +: WM_PRINT HEX: 0317 ; inline +: WM_PRINTCLIENT HEX: 0318 ; inline +: WM_APPCOMMAND HEX: 0319 ; inline +: WM_THEMECHANGED HEX: 031A ; inline +: WM_HANDHELDFIRST HEX: 0358 ; inline +: WM_HANDHELDLAST HEX: 035F ; inline +: WM_AFXFIRST HEX: 0360 ; inline +: WM_AFXLAST HEX: 037F ; inline +: WM_PENWINFIRST HEX: 0380 ; inline +: WM_PENWINLAST HEX: 038F ; inline +: WM_APP HEX: 8000 ; inline +: WM_USER HEX: 0400 ; inline +: EM_GETSEL HEX: 00B0 ; inline +: EM_SETSEL HEX: 00B1 ; inline +: EM_GETRECT HEX: 00B2 ; inline +: EM_SETRECT HEX: 00B3 ; inline +: EM_SETRECTNP HEX: 00B4 ; inline +: EM_SCROLL HEX: 00B5 ; inline +: EM_LINESCROLL HEX: 00B6 ; inline +: EM_SCROLLCARET HEX: 00B7 ; inline +: EM_GETMODIFY HEX: 00B8 ; inline +: EM_SETMODIFY HEX: 00B9 ; inline +: EM_GETLINECOUNT HEX: 00BA ; inline +: EM_LINEINDEX HEX: 00BB ; inline +: EM_SETHANDLE HEX: 00BC ; inline +: EM_GETHANDLE HEX: 00BD ; inline +: EM_GETTHUMB HEX: 00BE ; inline +: EM_LINELENGTH HEX: 00C1 ; inline +: EM_REPLACESEL HEX: 00C2 ; inline +: EM_GETLINE HEX: 00C4 ; inline +: EM_LIMITTEXT HEX: 00C5 ; inline +: EM_CANUNDO HEX: 00C6 ; inline +: EM_UNDO HEX: 00C7 ; inline +: EM_FMTLINES HEX: 00C8 ; inline +: EM_LINEFROMCHAR HEX: 00C9 ; inline +: EM_SETTABSTOPS HEX: 00CB ; inline +: EM_SETPASSWORDCHAR HEX: 00CC ; inline +: EM_EMPTYUNDOBUFFER HEX: 00CD ; inline +: EM_GETFIRSTVISIBLELINE HEX: 00CE ; inline +: EM_SETREADONLY HEX: 00CF ; inline +: EM_SETWORDBREAKPROC HEX: 00D0 ; inline +: EM_GETWORDBREAKPROC HEX: 00D1 ; inline +: EM_GETPASSWORDCHAR HEX: 00D2 ; inline +: EM_SETMARGINS HEX: 00D3 ; inline +: EM_GETMARGINS HEX: 00D4 ; inline +: EM_SETLIMITTEXT EM_LIMITTEXT ; inline +: EM_GETLIMITTEXT HEX: 00D5 ; inline +: EM_POSFROMCHAR HEX: 00D6 ; inline +: EM_CHARFROMPOS HEX: 00D7 ; inline +: EM_SETIMESTATUS HEX: 00D8 ; inline +: EM_GETIMESTATUS HEX: 00D9 ; inline +: BM_GETCHECK HEX: 00F0 ; inline +: BM_SETCHECK HEX: 00F1 ; inline +: BM_GETSTATE HEX: 00F2 ; inline +: BM_SETSTATE HEX: 00F3 ; inline +: BM_SETSTYLE HEX: 00F4 ; inline +: BM_CLICK HEX: 00F5 ; inline +: BM_GETIMAGE HEX: 00F6 ; inline +: BM_SETIMAGE HEX: 00F7 ; inline +: STM_SETICON HEX: 0170 ; inline +: STM_GETICON HEX: 0171 ; inline +: STM_SETIMAGE HEX: 0172 ; inline +: STM_GETIMAGE HEX: 0173 ; inline +: STM_MSGMAX HEX: 0174 ; inline +: DM_GETDEFID WM_USER ; inline +: DM_SETDEFID WM_USER 1 + ; inline +: DM_REPOSITION WM_USER 2 + ; inline +: LB_ADDSTRING HEX: 0180 ; inline +: LB_INSERTSTRING HEX: 0181 ; inline +: LB_DELETESTRING HEX: 0182 ; inline +: LB_SELITEMRANGEEX HEX: 0183 ; inline +: LB_RESETCONTENT HEX: 0184 ; inline +: LB_SETSEL HEX: 0185 ; inline +: LB_SETCURSEL HEX: 0186 ; inline +: LB_GETSEL HEX: 0187 ; inline +: LB_GETCURSEL HEX: 0188 ; inline +: LB_GETTEXT HEX: 0189 ; inline +: LB_GETTEXTLEN HEX: 018A ; inline +: LB_GETCOUNT HEX: 018B ; inline +: LB_SELECTSTRING HEX: 018C ; inline +: LB_DIR HEX: 018D ; inline +: LB_GETTOPINDEX HEX: 018E ; inline +: LB_FINDSTRING HEX: 018F ; inline +: LB_GETSELCOUNT HEX: 0190 ; inline +: LB_GETSELITEMS HEX: 0191 ; inline +: LB_SETTABSTOPS HEX: 0192 ; inline +: LB_GETHORIZONTALEXTENT HEX: 0193 ; inline +: LB_SETHORIZONTALEXTENT HEX: 0194 ; inline +: LB_SETCOLUMNWIDTH HEX: 0195 ; inline +: LB_ADDFILE HEX: 0196 ; inline +: LB_SETTOPINDEX HEX: 0197 ; inline +: LB_GETITEMRECT HEX: 0198 ; inline +: LB_GETITEMDATA HEX: 0199 ; inline +: LB_SETITEMDATA HEX: 019A ; inline +: LB_SELITEMRANGE HEX: 019B ; inline +: LB_SETANCHORINDEX HEX: 019C ; inline +: LB_GETANCHORINDEX HEX: 019D ; inline +: LB_SETCARETINDEX HEX: 019E ; inline +: LB_GETCARETINDEX HEX: 019F ; inline +: LB_SETITEMHEIGHT HEX: 01A0 ; inline +: LB_GETITEMHEIGHT HEX: 01A1 ; inline +: LB_FINDSTRINGEXACT HEX: 01A2 ; inline +: LB_SETLOCALE HEX: 01A5 ; inline +: LB_GETLOCALE HEX: 01A6 ; inline +: LB_SETCOUNT HEX: 01A7 ; inline +: LB_INITSTORAGE HEX: 01A8 ; inline +: LB_ITEMFROMPOINT HEX: 01A9 ; inline +: LB_MULTIPLEADDSTRING HEX: 01B1 ; inline +: LB_GETLISTBOXINFO HEX: 01B2 ; inline +: LB_MSGMAX_501 HEX: 01B3 ; inline +: LB_MSGMAX_WCE4 HEX: 01B1 ; inline +: LB_MSGMAX_4 HEX: 01B0 ; inline +: LB_MSGMAX_PRE4 HEX: 01A8 ; inline +: CB_GETEDITSEL HEX: 0140 ; inline +: CB_LIMITTEXT HEX: 0141 ; inline +: CB_SETEDITSEL HEX: 0142 ; inline +: CB_ADDSTRING HEX: 0143 ; inline +: CB_DELETESTRING HEX: 0144 ; inline +: CB_DIR HEX: 0145 ; inline +: CB_GETCOUNT HEX: 0146 ; inline +: CB_GETCURSEL HEX: 0147 ; inline +: CB_GETLBTEXT HEX: 0148 ; inline +: CB_GETLBTEXTLEN HEX: 0149 ; inline +: CB_INSERTSTRING HEX: 014A ; inline +: CB_RESETCONTENT HEX: 014B ; inline +: CB_FINDSTRING HEX: 014C ; inline +: CB_SELECTSTRING HEX: 014D ; inline +: CB_SETCURSEL HEX: 014E ; inline +: CB_SHOWDROPDOWN HEX: 014F ; inline +: CB_GETITEMDATA HEX: 0150 ; inline +: CB_SETITEMDATA HEX: 0151 ; inline +: CB_GETDROPPEDCONTROLRECT HEX: 0152 ; inline +: CB_SETITEMHEIGHT HEX: 0153 ; inline +: CB_GETITEMHEIGHT HEX: 0154 ; inline +: CB_SETEXTENDEDUI HEX: 0155 ; inline +: CB_GETEXTENDEDUI HEX: 0156 ; inline +: CB_GETDROPPEDSTATE HEX: 0157 ; inline +: CB_FINDSTRINGEXACT HEX: 0158 ; inline +: CB_SETLOCALE HEX: 0159 ; inline +: CB_GETLOCALE HEX: 015A ; inline +: CB_GETTOPINDEX HEX: 015B ; inline +: CB_SETTOPINDEX HEX: 015C ; inline +: CB_GETHORIZONTALEXTENT HEX: 015d ; inline +: CB_SETHORIZONTALEXTENT HEX: 015e ; inline +: CB_GETDROPPEDWIDTH HEX: 015f ; inline +: CB_SETDROPPEDWIDTH HEX: 0160 ; inline +: CB_INITSTORAGE HEX: 0161 ; inline +: CB_MULTIPLEADDSTRING HEX: 0163 ; inline +: CB_GETCOMBOBOXINFO HEX: 0164 ; inline +: CB_MSGMAX_501 HEX: 0165 ; inline +: CB_MSGMAX_WCE400 HEX: 0163 ; inline +: CB_MSGMAX_400 HEX: 0162 ; inline +: CB_MSGMAX_PRE400 HEX: 015B ; inline +: SBM_SETPOS HEX: 00E0 ; inline +: SBM_GETPOS HEX: 00E1 ; inline +: SBM_SETRANGE HEX: 00E2 ; inline +: SBM_SETRANGEREDRAW HEX: 00E6 ; inline +: SBM_GETRANGE HEX: 00E3 ; inline +: SBM_ENABLE_ARROWS HEX: 00E4 ; inline +: SBM_SETSCROLLINFO HEX: 00E9 ; inline +: SBM_GETSCROLLINFO HEX: 00EA ; inline +: SBM_GETSCROLLBARINFO HEX: 00EB ; inline +: LVM_FIRST HEX: 1000 ; inline ! ListView messages +: TV_FIRST HEX: 1100 ; inline ! TreeView messages +: HDM_FIRST HEX: 1200 ; inline ! Header messages +: TCM_FIRST HEX: 1300 ; inline ! Tab control messages +: PGM_FIRST HEX: 1400 ; inline ! Pager control messages +: ECM_FIRST HEX: 1500 ; inline ! Edit control messages +: BCM_FIRST HEX: 1600 ; inline ! Button control messages +: CBM_FIRST HEX: 1700 ; inline ! Combobox control messages +: CCM_FIRST HEX: 2000 ; inline ! Common control shared messages +: CCM_LAST CCM_FIRST HEX: 0200 + ; inline +: CCM_SETBKCOLOR CCM_FIRST 1 + ; inline +: CCM_SETCOLORSCHEME CCM_FIRST 2 + ; inline +: CCM_GETCOLORSCHEME CCM_FIRST 3 + ; inline +: CCM_GETDROPTARGET CCM_FIRST 4 + ; inline +: CCM_SETUNICODEFORMAT CCM_FIRST 5 + ; inline +: CCM_GETUNICODEFORMAT CCM_FIRST 6 + ; inline +: CCM_SETVERSION CCM_FIRST 7 + ; inline +: CCM_GETVERSION CCM_FIRST 8 + ; inline +: CCM_SETNOTIFYWINDOW CCM_FIRST 9 + ; inline +: CCM_SETWINDOWTHEME CCM_FIRST HEX: b + ; inline +: CCM_DPISCALE CCM_FIRST HEX: c + ; inline +: HDM_GETITEMCOUNT HDM_FIRST 0 + ; inline +: HDM_INSERTITEMA HDM_FIRST 1 + ; inline +: HDM_INSERTITEMW HDM_FIRST 10 + ; inline +: HDM_DELETEITEM HDM_FIRST 2 + ; inline +: HDM_GETITEMA HDM_FIRST 3 + ; inline +: HDM_GETITEMW HDM_FIRST 11 + ; inline +: HDM_SETITEMA HDM_FIRST 4 + ; inline +: HDM_SETITEMW HDM_FIRST 12 + ; inline +: HDM_LAYOUT HDM_FIRST 5 + ; inline +: HDM_HITTEST HDM_FIRST 6 + ; inline +: HDM_GETITEMRECT HDM_FIRST 7 + ; inline +: HDM_SETIMAGELIST HDM_FIRST 8 + ; inline +: HDM_GETIMAGELIST HDM_FIRST 9 + ; inline +: HDM_ORDERTOINDEX HDM_FIRST 15 + ; inline +: HDM_CREATEDRAGIMAGE HDM_FIRST 16 + ; inline +: HDM_GETORDERARRAY HDM_FIRST 17 + ; inline +: HDM_SETORDERARRAY HDM_FIRST 18 + ; inline +: HDM_SETHOTDIVIDER HDM_FIRST 19 + ; inline +: HDM_SETBITMAPMARGIN HDM_FIRST 20 + ; inline +: HDM_GETBITMAPMARGIN HDM_FIRST 21 + ; inline +: HDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: HDM_SETFILTERCHANGETIMEOUT HDM_FIRST 22 + ; inline +: HDM_EDITFILTER HDM_FIRST 23 + ; inline +: HDM_CLEARFILTER HDM_FIRST 24 + ; inline +: TB_ENABLEBUTTON WM_USER 1 + ; inline +: TB_CHECKBUTTON WM_USER 2 + ; inline +: TB_PRESSBUTTON WM_USER 3 + ; inline +: TB_HIDEBUTTON WM_USER 4 + ; inline +: TB_INDETERMINATE WM_USER 5 + ; inline +: TB_MARKBUTTON WM_USER 6 + ; inline +: TB_ISBUTTONENABLED WM_USER 9 + ; inline +: TB_ISBUTTONCHECKED WM_USER 10 + ; inline +: TB_ISBUTTONPRESSED WM_USER 11 + ; inline +: TB_ISBUTTONHIDDEN WM_USER 12 + ; inline +: TB_ISBUTTONINDETERMINATE WM_USER 13 + ; inline +: TB_ISBUTTONHIGHLIGHTED WM_USER 14 + ; inline +: TB_SETSTATE WM_USER 17 + ; inline +: TB_GETSTATE WM_USER 18 + ; inline +: TB_ADDBITMAP WM_USER 19 + ; inline +: TB_ADDBUTTONSA WM_USER 20 + ; inline +: TB_INSERTBUTTONA WM_USER 21 + ; inline +: TB_ADDBUTTONS WM_USER 20 + ; inline +: TB_INSERTBUTTON WM_USER 21 + ; inline +: TB_DELETEBUTTON WM_USER 22 + ; inline +: TB_GETBUTTON WM_USER 23 + ; inline +: TB_BUTTONCOUNT WM_USER 24 + ; inline +: TB_COMMANDTOINDEX WM_USER 25 + ; inline +: TB_SAVERESTOREA WM_USER 26 + ; inline +: TB_SAVERESTOREW WM_USER 76 + ; inline +: TB_CUSTOMIZE WM_USER 27 + ; inline +: TB_ADDSTRINGA WM_USER 28 + ; inline +: TB_ADDSTRINGW WM_USER 77 + ; inline +: TB_GETITEMRECT WM_USER 29 + ; inline +: TB_BUTTONSTRUCTSIZE WM_USER 30 + ; inline +: TB_SETBUTTONSIZE WM_USER 31 + ; inline +: TB_SETBITMAPSIZE WM_USER 32 + ; inline +: TB_AUTOSIZE WM_USER 33 + ; inline +: TB_GETTOOLTIPS WM_USER 35 + ; inline +: TB_SETTOOLTIPS WM_USER 36 + ; inline +: TB_SETPARENT WM_USER 37 + ; inline +: TB_SETROWS WM_USER 39 + ; inline +: TB_GETROWS WM_USER 40 + ; inline +: TB_SETCMDID WM_USER 42 + ; inline +: TB_CHANGEBITMAP WM_USER 43 + ; inline +: TB_GETBITMAP WM_USER 44 + ; inline +: TB_GETBUTTONTEXTA WM_USER 45 + ; inline +: TB_GETBUTTONTEXTW WM_USER 75 + ; inline +: TB_REPLACEBITMAP WM_USER 46 + ; inline +: TB_SETINDENT WM_USER 47 + ; inline +: TB_SETIMAGELIST WM_USER 48 + ; inline +: TB_GETIMAGELIST WM_USER 49 + ; inline +: TB_LOADIMAGES WM_USER 50 + ; inline +: TB_GETRECT WM_USER 51 + ; inline +: TB_SETHOTIMAGELIST WM_USER 52 + ; inline +: TB_GETHOTIMAGELIST WM_USER 53 + ; inline +: TB_SETDISABLEDIMAGELIST WM_USER 54 + ; inline +: TB_GETDISABLEDIMAGELIST WM_USER 55 + ; inline +: TB_SETSTYLE WM_USER 56 + ; inline +: TB_GETSTYLE WM_USER 57 + ; inline +: TB_GETBUTTONSIZE WM_USER 58 + ; inline +: TB_SETBUTTONWIDTH WM_USER 59 + ; inline +: TB_SETMAXTEXTROWS WM_USER 60 + ; inline +: TB_GETTEXTROWS WM_USER 61 + ; inline +: TB_GETOBJECT WM_USER 62 + ; inline +: TB_GETHOTITEM WM_USER 71 + ; inline +: TB_SETHOTITEM WM_USER 72 + ; inline +: TB_SETANCHORHIGHLIGHT WM_USER 73 + ; inline +: TB_GETANCHORHIGHLIGHT WM_USER 74 + ; inline +: TB_MAPACCELERATORA WM_USER 78 + ; inline +: TB_GETINSERTMARK WM_USER 79 + ; inline +: TB_SETINSERTMARK WM_USER 80 + ; inline +: TB_INSERTMARKHITTEST WM_USER 81 + ; inline +: TB_MOVEBUTTON WM_USER 82 + ; inline +: TB_GETMAXSIZE WM_USER 83 + ; inline +: TB_SETEXTENDEDSTYLE WM_USER 84 + ; inline +: TB_GETEXTENDEDSTYLE WM_USER 85 + ; inline +: TB_GETPADDING WM_USER 86 + ; inline +: TB_SETPADDING WM_USER 87 + ; inline +: TB_SETINSERTMARKCOLOR WM_USER 88 + ; inline +: TB_GETINSERTMARKCOLOR WM_USER 89 + ; inline +: TB_SETCOLORSCHEME CCM_SETCOLORSCHEME ; inline +: TB_GETCOLORSCHEME CCM_GETCOLORSCHEME ; inline +: TB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: TB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: TB_MAPACCELERATORW WM_USER 90 + ; inline +: TB_GETBITMAPFLAGS WM_USER 41 + ; inline +: TB_GETBUTTONINFOW WM_USER 63 + ; inline +: TB_SETBUTTONINFOW WM_USER 64 + ; inline +: TB_GETBUTTONINFOA WM_USER 65 + ; inline +: TB_SETBUTTONINFOA WM_USER 66 + ; inline +: TB_INSERTBUTTONW WM_USER 67 + ; inline +: TB_ADDBUTTONSW WM_USER 68 + ; inline +: TB_HITTEST WM_USER 69 + ; inline +: TB_SETDRAWTEXTFLAGS WM_USER 70 + ; inline +: TB_GETSTRINGW WM_USER 91 + ; inline +: TB_GETSTRINGA WM_USER 92 + ; inline +: TB_GETMETRICS WM_USER 101 + ; inline +: TB_SETMETRICS WM_USER 102 + ; inline +: TB_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline +: RB_INSERTBANDA WM_USER 1 + ; inline +: RB_DELETEBAND WM_USER 2 + ; inline +: RB_GETBARINFO WM_USER 3 + ; inline +: RB_SETBARINFO WM_USER 4 + ; inline +: RB_GETBANDINFO WM_USER 5 + ; inline +: RB_SETBANDINFOA WM_USER 6 + ; inline +: RB_SETPARENT WM_USER 7 + ; inline +: RB_HITTEST WM_USER 8 + ; inline +: RB_GETRECT WM_USER 9 + ; inline +: RB_INSERTBANDW WM_USER 10 + ; inline +: RB_SETBANDINFOW WM_USER 11 + ; inline +: RB_GETBANDCOUNT WM_USER 12 + ; inline +: RB_GETROWCOUNT WM_USER 13 + ; inline +: RB_GETROWHEIGHT WM_USER 14 + ; inline +: RB_IDTOINDEX WM_USER 16 + ; inline +: RB_GETTOOLTIPS WM_USER 17 + ; inline +: RB_SETTOOLTIPS WM_USER 18 + ; inline +: RB_SETBKCOLOR WM_USER 19 + ; inline +: RB_GETBKCOLOR WM_USER 20 + ; inline +: RB_SETTEXTCOLOR WM_USER 21 + ; inline +: RB_GETTEXTCOLOR WM_USER 22 + ; inline +: RB_SIZETORECT WM_USER 23 + ; inline +: RB_SETCOLORSCHEME CCM_SETCOLORSCHEME ; inline +: RB_GETCOLORSCHEME CCM_GETCOLORSCHEME ; inline +: RB_BEGINDRAG WM_USER 24 + ; inline +: RB_ENDDRAG WM_USER 25 + ; inline +: RB_DRAGMOVE WM_USER 26 + ; inline +: RB_GETBARHEIGHT WM_USER 27 + ; inline +: RB_GETBANDINFOW WM_USER 28 + ; inline +: RB_GETBANDINFOA WM_USER 29 + ; inline +: RB_MINIMIZEBAND WM_USER 30 + ; inline +: RB_MAXIMIZEBAND WM_USER 31 + ; inline +: RB_GETDROPTARGET CCM_GETDROPTARGET ; inline +: RB_GETBANDBORDERS WM_USER 34 + ; inline +: RB_SHOWBAND WM_USER 35 + ; inline +: RB_SETPALETTE WM_USER 37 + ; inline +: RB_GETPALETTE WM_USER 38 + ; inline +: RB_MOVEBAND WM_USER 39 + ; inline +: RB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: RB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: RB_GETBANDMARGINS WM_USER 40 + ; inline +: RB_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline +: RB_PUSHCHEVRON WM_USER 43 + ; inline +: TTM_ACTIVATE WM_USER 1 + ; inline +: TTM_SETDELAYTIME WM_USER 3 + ; inline +: TTM_ADDTOOLA WM_USER 4 + ; inline +: TTM_ADDTOOLW WM_USER 50 + ; inline +: TTM_DELTOOLA WM_USER 5 + ; inline +: TTM_DELTOOLW WM_USER 51 + ; inline +: TTM_NEWTOOLRECTA WM_USER 6 + ; inline +: TTM_NEWTOOLRECTW WM_USER 52 + ; inline +: TTM_RELAYEVENT WM_USER 7 + ; inline +: TTM_GETTOOLINFOA WM_USER 8 + ; inline +: TTM_GETTOOLINFOW WM_USER 53 + ; inline +: TTM_SETTOOLINFOA WM_USER 9 + ; inline +: TTM_SETTOOLINFOW WM_USER 54 + ; inline +: TTM_HITTESTA WM_USER 10 + ; inline +: TTM_HITTESTW WM_USER 55 + ; inline +: TTM_GETTEXTA WM_USER 11 + ; inline +: TTM_GETTEXTW WM_USER 56 + ; inline +: TTM_UPDATETIPTEXTA WM_USER 12 + ; inline +: TTM_UPDATETIPTEXTW WM_USER 57 + ; inline +: TTM_GETTOOLCOUNT WM_USER 13 + ; inline +: TTM_ENUMTOOLSA WM_USER 14 + ; inline +: TTM_ENUMTOOLSW WM_USER 58 + ; inline +: TTM_GETCURRENTTOOLA WM_USER 15 + ; inline +: TTM_GETCURRENTTOOLW WM_USER 59 + ; inline +: TTM_WINDOWFROMPOINT WM_USER 16 + ; inline +: TTM_TRACKACTIVATE WM_USER 17 + ; inline +: TTM_TRACKPOSITION WM_USER 18 + ; inline +: TTM_SETTIPBKCOLOR WM_USER 19 + ; inline +: TTM_SETTIPTEXTCOLOR WM_USER 20 + ; inline +: TTM_GETDELAYTIME WM_USER 21 + ; inline +: TTM_GETTIPBKCOLOR WM_USER 22 + ; inline +: TTM_GETTIPTEXTCOLOR WM_USER 23 + ; inline +: TTM_SETMAXTIPWIDTH WM_USER 24 + ; inline +: TTM_GETMAXTIPWIDTH WM_USER 25 + ; inline +: TTM_SETMARGIN WM_USER 26 + ; inline +: TTM_GETMARGIN WM_USER 27 + ; inline +: TTM_POP WM_USER 28 + ; inline +: TTM_UPDATE WM_USER 29 + ; inline +: TTM_GETBUBBLESIZE WM_USER 30 + ; inline +: TTM_ADJUSTRECT WM_USER 31 + ; inline +: TTM_SETTITLEA WM_USER 32 + ; inline +: TTM_SETTITLEW WM_USER 33 + ; inline +: TTM_POPUP WM_USER 34 + ; inline +: TTM_GETTITLE WM_USER 35 + ; inline +: TTM_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline +: SB_SETTEXTA WM_USER 1+ ; inline +: SB_SETTEXTW WM_USER 11 + ; inline +: SB_GETTEXTA WM_USER 2 + ; inline +: SB_GETTEXTW WM_USER 13 + ; inline +: SB_GETTEXTLENGTHA WM_USER 3 + ; inline +: SB_GETTEXTLENGTHW WM_USER 12 + ; inline +: SB_SETPARTS WM_USER 4 + ; inline +: SB_GETPARTS WM_USER 6 + ; inline +: SB_GETBORDERS WM_USER 7 + ; inline +: SB_SETMINHEIGHT WM_USER 8 + ; inline +: SB_SIMPLE WM_USER 9 + ; inline +: SB_GETRECT WM_USER 10 + ; inline +: SB_ISSIMPLE WM_USER 14 + ; inline +: SB_SETICON WM_USER 15 + ; inline +: SB_SETTIPTEXTA WM_USER 16 + ; inline +: SB_SETTIPTEXTW WM_USER 17 + ; inline +: SB_GETTIPTEXTA WM_USER 18 + ; inline +: SB_GETTIPTEXTW WM_USER 19 + ; inline +: SB_GETICON WM_USER 20 + ; inline +: SB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: SB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: SB_SETBKCOLOR CCM_SETBKCOLOR ; inline +: SB_SIMPLEID HEX: 00ff ; inline +: TBM_GETPOS WM_USER ; inline +: TBM_GETRANGEMIN WM_USER 1 + ; inline +: TBM_GETRANGEMAX WM_USER 2 + ; inline +: TBM_GETTIC WM_USER 3 + ; inline +: TBM_SETTIC WM_USER 4 + ; inline +: TBM_SETPOS WM_USER 5 + ; inline +: TBM_SETRANGE WM_USER 6 + ; inline +: TBM_SETRANGEMIN WM_USER 7 + ; inline +: TBM_SETRANGEMAX WM_USER 8 + ; inline +: TBM_CLEARTICS WM_USER 9 + ; inline +: TBM_SETSEL WM_USER 10 + ; inline +: TBM_SETSELSTART WM_USER 11 + ; inline +: TBM_SETSELEND WM_USER 12 + ; inline +: TBM_GETPTICS WM_USER 14 + ; inline +: TBM_GETTICPOS WM_USER 15 + ; inline +: TBM_GETNUMTICS WM_USER 16 + ; inline +: TBM_GETSELSTART WM_USER 17 + ; inline +: TBM_GETSELEND WM_USER 18 + ; inline +: TBM_CLEARSEL WM_USER 19 + ; inline +: TBM_SETTICFREQ WM_USER 20 + ; inline +: TBM_SETPAGESIZE WM_USER 21 + ; inline +: TBM_GETPAGESIZE WM_USER 22 + ; inline +: TBM_SETLINESIZE WM_USER 23 + ; inline +: TBM_GETLINESIZE WM_USER 24 + ; inline +: TBM_GETTHUMBRECT WM_USER 25 + ; inline +: TBM_GETCHANNELRECT WM_USER 26 + ; inline +: TBM_SETTHUMBLENGTH WM_USER 27 + ; inline +: TBM_GETTHUMBLENGTH WM_USER 28 + ; inline +: TBM_SETTOOLTIPS WM_USER 29 + ; inline +: TBM_GETTOOLTIPS WM_USER 30 + ; inline +: TBM_SETTIPSIDE WM_USER 31 + ; inline +: TBM_SETBUDDY WM_USER 32 + ; inline +: TBM_GETBUDDY WM_USER 33 + ; inline +: TBM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: TBM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: DL_BEGINDRAG WM_USER 133 + ; inline +: DL_DRAGGING WM_USER 134 + ; inline +: DL_DROPPED WM_USER 135 + ; inline +: DL_CANCELDRAG WM_USER 136 + ; inline +: UDM_SETRANGE WM_USER 101 + ; inline +: UDM_GETRANGE WM_USER 102 + ; inline +: UDM_SETPOS WM_USER 103 + ; inline +: UDM_GETPOS WM_USER 104 + ; inline +: UDM_SETBUDDY WM_USER 105 + ; inline +: UDM_GETBUDDY WM_USER 106 + ; inline +: UDM_SETACCEL WM_USER 107 + ; inline +: UDM_GETACCEL WM_USER 108 + ; inline +: UDM_SETBASE WM_USER 109 + ; inline +: UDM_GETBASE WM_USER 110 + ; inline +: UDM_SETRANGE32 WM_USER 111 + ; inline +: UDM_GETRANGE32 WM_USER 112 + ; inline +: UDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: UDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: UDM_SETPOS32 WM_USER 113 + ; inline +: UDM_GETPOS32 WM_USER 114 + ; inline +: PBM_SETRANGE WM_USER 1 + ; inline +: PBM_SETPOS WM_USER 2 + ; inline +: PBM_DELTAPOS WM_USER 3 + ; inline +: PBM_SETSTEP WM_USER 4 + ; inline +: PBM_STEPIT WM_USER 5 + ; inline +: PBM_SETRANGE32 WM_USER 6 + ; inline +: PBM_GETRANGE WM_USER 7 + ; inline +: PBM_GETPOS WM_USER 8 + ; inline +: PBM_SETBARCOLOR WM_USER 9 + ; inline +: PBM_SETBKCOLOR CCM_SETBKCOLOR ; inline +: HKM_SETHOTKEY WM_USER 1 + ; inline +: HKM_GETHOTKEY WM_USER 2 + ; inline +: HKM_SETRULES WM_USER 3 + ; inline +: LVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: LVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: LVM_GETBKCOLOR LVM_FIRST 0 + ; inline +: LVM_SETBKCOLOR LVM_FIRST 1 + ; inline +: LVM_GETIMAGELIST LVM_FIRST 2 + ; inline +: LVM_SETIMAGELIST LVM_FIRST 3 + ; inline +: LVM_GETITEMCOUNT LVM_FIRST 4 + ; inline +: LVM_GETITEMA LVM_FIRST 5 + ; inline +: LVM_GETITEMW LVM_FIRST 75 + ; inline +: LVM_SETITEMA LVM_FIRST 6 + ; inline +: LVM_SETITEMW LVM_FIRST 76 + ; inline +: LVM_INSERTITEMA LVM_FIRST 7 + ; inline +: LVM_INSERTITEMW LVM_FIRST 77 + ; inline +: LVM_DELETEITEM LVM_FIRST 8 + ; inline +: LVM_DELETEALLITEMS LVM_FIRST 9 + ; inline +: LVM_GETCALLBACKMASK LVM_FIRST 10 + ; inline +: LVM_SETCALLBACKMASK LVM_FIRST 11 + ; inline +: LVM_FINDITEMA LVM_FIRST 13 + ; inline +: LVM_FINDITEMW LVM_FIRST 83 + ; inline +: LVM_GETITEMRECT LVM_FIRST 14 + ; inline +: LVM_SETITEMPOSITION LVM_FIRST 15 + ; inline +: LVM_GETITEMPOSITION LVM_FIRST 16 + ; inline +: LVM_GETSTRINGWIDTHA LVM_FIRST 17 + ; inline +: LVM_GETSTRINGWIDTHW LVM_FIRST 87 + ; inline +: LVM_HITTEST LVM_FIRST 18 + ; inline +: LVM_ENSUREVISIBLE LVM_FIRST 19 + ; inline +: LVM_SCROLL LVM_FIRST 20 + ; inline +: LVM_REDRAWITEMS LVM_FIRST 21 + ; inline +: LVM_ARRANGE LVM_FIRST 22 + ; inline +: LVM_EDITLABELA LVM_FIRST 23 + ; inline +: LVM_EDITLABELW LVM_FIRST 118 + ; inline +: LVM_GETEDITCONTROL LVM_FIRST 24 + ; inline +: LVM_GETCOLUMNA LVM_FIRST 25 + ; inline +: LVM_GETCOLUMNW LVM_FIRST 95 + ; inline +: LVM_SETCOLUMNA LVM_FIRST 26 + ; inline +: LVM_SETCOLUMNW LVM_FIRST 96 + ; inline +: LVM_INSERTCOLUMNA LVM_FIRST 27 + ; inline +: LVM_INSERTCOLUMNW LVM_FIRST 97 + ; inline +: LVM_DELETECOLUMN LVM_FIRST 28 + ; inline +: LVM_GETCOLUMNWIDTH LVM_FIRST 29 + ; inline +: LVM_SETCOLUMNWIDTH LVM_FIRST 30 + ; inline +: LVM_CREATEDRAGIMAGE LVM_FIRST 33 + ; inline +: LVM_GETVIEWRECT LVM_FIRST 34 + ; inline +: LVM_GETTEXTCOLOR LVM_FIRST 35 + ; inline +: LVM_SETTEXTCOLOR LVM_FIRST 36 + ; inline +: LVM_GETTEXTBKCOLOR LVM_FIRST 37 + ; inline +: LVM_SETTEXTBKCOLOR LVM_FIRST 38 + ; inline +: LVM_GETTOPINDEX LVM_FIRST 39 + ; inline +: LVM_GETCOUNTPERPAGE LVM_FIRST 40 + ; inline +: LVM_GETORIGIN LVM_FIRST 41 + ; inline +: LVM_UPDATE LVM_FIRST 42 + ; inline +: LVM_SETITEMSTATE LVM_FIRST 43 + ; inline +: LVM_GETITEMSTATE LVM_FIRST 44 + ; inline +: LVM_GETITEMTEXTA LVM_FIRST 45 + ; inline +: LVM_GETITEMTEXTW LVM_FIRST 115 + ; inline +: LVM_SETITEMTEXTA LVM_FIRST 46 + ; inline +: LVM_SETITEMTEXTW LVM_FIRST 116 + ; inline +: LVM_SETITEMCOUNT LVM_FIRST 47 + ; inline +: LVM_SORTITEMS LVM_FIRST 48 + ; inline +: LVM_SETITEMPOSITION32 LVM_FIRST 49 + ; inline +: LVM_GETSELECTEDCOUNT LVM_FIRST 50 + ; inline +: LVM_GETITEMSPACING LVM_FIRST 51 + ; inline +: LVM_GETISEARCHSTRINGA LVM_FIRST 52 + ; inline +: LVM_GETISEARCHSTRINGW LVM_FIRST 117 + ; inline +: LVM_SETICONSPACING LVM_FIRST 53 + ; inline +: LVM_SETEXTENDEDLISTVIEWSTYLE LVM_FIRST 54 + ; inline +: LVM_GETEXTENDEDLISTVIEWSTYLE LVM_FIRST 55 + ; inline +: LVM_GETSUBITEMRECT LVM_FIRST 56 + ; inline +: LVM_SUBITEMHITTEST LVM_FIRST 57 + ; inline +: LVM_SETCOLUMNORDERARRAY LVM_FIRST 58 + ; inline +: LVM_GETCOLUMNORDERARRAY LVM_FIRST 59 + ; inline +: LVM_SETHOTITEM LVM_FIRST 60 + ; inline +: LVM_GETHOTITEM LVM_FIRST 61 + ; inline +: LVM_SETHOTCURSOR LVM_FIRST 62 + ; inline +: LVM_GETHOTCURSOR LVM_FIRST 63 + ; inline +: LVM_APPROXIMATEVIEWRECT LVM_FIRST 64 + ; inline +: LVM_SETWORKAREAS LVM_FIRST 65 + ; inline +: LVM_GETWORKAREAS LVM_FIRST 70 + ; inline +: LVM_GETNUMBEROFWORKAREAS LVM_FIRST 73 + ; inline +: LVM_GETSELECTIONMARK LVM_FIRST 66 + ; inline +: LVM_SETSELECTIONMARK LVM_FIRST 67 + ; inline +: LVM_SETHOVERTIME LVM_FIRST 71 + ; inline +: LVM_GETHOVERTIME LVM_FIRST 72 + ; inline +: LVM_SETTOOLTIPS LVM_FIRST 74 + ; inline +: LVM_GETTOOLTIPS LVM_FIRST 78 + ; inline +: LVM_SORTITEMSEX LVM_FIRST 81 + ; inline +: LVM_SETBKIMAGEA LVM_FIRST 68 + ; inline +: LVM_SETBKIMAGEW LVM_FIRST 138 + ; inline +: LVM_GETBKIMAGEA LVM_FIRST 69 + ; inline +: LVM_GETBKIMAGEW LVM_FIRST 139 + ; inline +: LVM_SETSELECTEDCOLUMN LVM_FIRST 140 + ; inline +: LVM_SETTILEWIDTH LVM_FIRST 141 + ; inline +: LVM_SETVIEW LVM_FIRST 142 + ; inline +: LVM_GETVIEW LVM_FIRST 143 + ; inline +: LVM_INSERTGROUP LVM_FIRST 145 + ; inline +: LVM_SETGROUPINFO LVM_FIRST 147 + ; inline +: LVM_GETGROUPINFO LVM_FIRST 149 + ; inline +: LVM_REMOVEGROUP LVM_FIRST 150 + ; inline +: LVM_MOVEGROUP LVM_FIRST 151 + ; inline +: LVM_MOVEITEMTOGROUP LVM_FIRST 154 + ; inline +: LVM_SETGROUPMETRICS LVM_FIRST 155 + ; inline +: LVM_GETGROUPMETRICS LVM_FIRST 156 + ; inline +: LVM_ENABLEGROUPVIEW LVM_FIRST 157 + ; inline +: LVM_SORTGROUPS LVM_FIRST 158 + ; inline +: LVM_INSERTGROUPSORTED LVM_FIRST 159 + ; inline +: LVM_REMOVEALLGROUPS LVM_FIRST 160 + ; inline +: LVM_HASGROUP LVM_FIRST 161 + ; inline +: LVM_SETTILEVIEWINFO LVM_FIRST 162 + ; inline +: LVM_GETTILEVIEWINFO LVM_FIRST 163 + ; inline +: LVM_SETTILEINFO LVM_FIRST 164 + ; inline +: LVM_GETTILEINFO LVM_FIRST 165 + ; inline +: LVM_SETINSERTMARK LVM_FIRST 166 + ; inline +: LVM_GETINSERTMARK LVM_FIRST 167 + ; inline +: LVM_INSERTMARKHITTEST LVM_FIRST 168 + ; inline +: LVM_GETINSERTMARKRECT LVM_FIRST 169 + ; inline +: LVM_SETINSERTMARKCOLOR LVM_FIRST 170 + ; inline +: LVM_GETINSERTMARKCOLOR LVM_FIRST 171 + ; inline +: LVM_SETINFOTIP LVM_FIRST 173 + ; inline +: LVM_GETSELECTEDCOLUMN LVM_FIRST 174 + ; inline +: LVM_ISGROUPVIEWENABLED LVM_FIRST 175 + ; inline +: LVM_GETOUTLINECOLOR LVM_FIRST 176 + ; inline +: LVM_SETOUTLINECOLOR LVM_FIRST 177 + ; inline +: LVM_CANCELEDITLABEL LVM_FIRST 179 + ; inline +: LVM_MAPINDEXTOID LVM_FIRST 180 + ; inline +: LVM_MAPIDTOINDEX LVM_FIRST 181 + ; inline +: TVM_INSERTITEMA TV_FIRST 0 + ; inline +: TVM_INSERTITEMW TV_FIRST 50 + ; inline +: TVM_DELETEITEM TV_FIRST 1 + ; inline +: TVM_EXPAND TV_FIRST 2 + ; inline +: TVM_GETITEMRECT TV_FIRST 4 + ; inline +: TVM_GETCOUNT TV_FIRST 5 + ; inline +: TVM_GETINDENT TV_FIRST 6 + ; inline +: TVM_SETINDENT TV_FIRST 7 + ; inline +: TVM_GETIMAGELIST TV_FIRST 8 + ; inline +: TVM_SETIMAGELIST TV_FIRST 9 + ; inline +: TVM_GETNEXTITEM TV_FIRST 10 + ; inline +: TVM_SELECTITEM TV_FIRST 11 + ; inline +: TVM_GETITEMA TV_FIRST 12 + ; inline +: TVM_GETITEMW TV_FIRST 62 + ; inline +: TVM_SETITEMA TV_FIRST 13 + ; inline +: TVM_SETITEMW TV_FIRST 63 + ; inline +: TVM_EDITLABELA TV_FIRST 14 + ; inline +: TVM_EDITLABELW TV_FIRST 65 + ; inline +: TVM_GETEDITCONTROL TV_FIRST 15 + ; inline +: TVM_GETVISIBLECOUNT TV_FIRST 16 + ; inline +: TVM_HITTEST TV_FIRST 17 + ; inline +: TVM_CREATEDRAGIMAGE TV_FIRST 18 + ; inline +: TVM_SORTCHILDREN TV_FIRST 19 + ; inline +: TVM_ENSUREVISIBLE TV_FIRST 20 + ; inline +: TVM_SORTCHILDRENCB TV_FIRST 21 + ; inline +: TVM_ENDEDITLABELNOW TV_FIRST 22 + ; inline +: TVM_GETISEARCHSTRINGA TV_FIRST 23 + ; inline +: TVM_GETISEARCHSTRINGW TV_FIRST 64 + ; inline +: TVM_SETTOOLTIPS TV_FIRST 24 + ; inline +: TVM_GETTOOLTIPS TV_FIRST 25 + ; inline +: TVM_SETINSERTMARK TV_FIRST 26 + ; inline +: TVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: TVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: TVM_SETITEMHEIGHT TV_FIRST 27 + ; inline +: TVM_GETITEMHEIGHT TV_FIRST 28 + ; inline +: TVM_SETBKCOLOR TV_FIRST 29 + ; inline +: TVM_SETTEXTCOLOR TV_FIRST 30 + ; inline +: TVM_GETBKCOLOR TV_FIRST 31 + ; inline +: TVM_GETTEXTCOLOR TV_FIRST 32 + ; inline +: TVM_SETSCROLLTIME TV_FIRST 33 + ; inline +: TVM_GETSCROLLTIME TV_FIRST 34 + ; inline +: TVM_SETINSERTMARKCOLOR TV_FIRST 37 + ; inline +: TVM_GETINSERTMARKCOLOR TV_FIRST 38 + ; inline +: TVM_GETITEMSTATE TV_FIRST 39 + ; inline +: TVM_SETLINECOLOR TV_FIRST 40 + ; inline +: TVM_GETLINECOLOR TV_FIRST 41 + ; inline +: TVM_MAPACCIDTOHTREEITEM TV_FIRST 42 + ; inline +: TVM_MAPHTREEITEMTOACCID TV_FIRST 43 + ; inline +: CBEM_INSERTITEMA WM_USER 1 + ; inline +: CBEM_SETIMAGELIST WM_USER 2 + ; inline +: CBEM_GETIMAGELIST WM_USER 3 + ; inline +: CBEM_GETITEMA WM_USER 4 + ; inline +: CBEM_SETITEMA WM_USER 5 + ; inline +: CBEM_DELETEITEM CB_DELETESTRING ; inline +: CBEM_GETCOMBOCONTROL WM_USER 6 + ; inline +: CBEM_GETEDITCONTROL WM_USER 7 + ; inline +: CBEM_SETEXTENDEDSTYLE WM_USER 14 + ; inline +: CBEM_GETEXTENDEDSTYLE WM_USER 9 + ; inline +: CBEM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: CBEM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: CBEM_SETEXSTYLE WM_USER 8 + ; inline +: CBEM_GETEXSTYLE WM_USER 9 + ; inline +: CBEM_HASEDITCHANGED WM_USER 10 + ; inline +: CBEM_INSERTITEMW WM_USER 11 + ; inline +: CBEM_SETITEMW WM_USER 12 + ; inline +: CBEM_GETITEMW WM_USER 13 + ; inline +: TCM_GETIMAGELIST TCM_FIRST 2 + ; inline +: TCM_SETIMAGELIST TCM_FIRST 3 + ; inline +: TCM_GETITEMCOUNT TCM_FIRST 4 + ; inline +: TCM_GETITEMA TCM_FIRST 5 + ; inline +: TCM_GETITEMW TCM_FIRST 60 + ; inline +: TCM_SETITEMA TCM_FIRST 6 + ; inline +: TCM_SETITEMW TCM_FIRST 61 + ; inline +: TCM_INSERTITEMA TCM_FIRST 7 + ; inline +: TCM_INSERTITEMW TCM_FIRST 62 + ; inline +: TCM_DELETEITEM TCM_FIRST 8 + ; inline +: TCM_DELETEALLITEMS TCM_FIRST 9 + ; inline +: TCM_GETITEMRECT TCM_FIRST 10 + ; inline +: TCM_GETCURSEL TCM_FIRST 11 + ; inline +: TCM_SETCURSEL TCM_FIRST 12 + ; inline +: TCM_HITTEST TCM_FIRST 13 + ; inline +: TCM_SETITEMEXTRA TCM_FIRST 14 + ; inline +: TCM_ADJUSTRECT TCM_FIRST 40 + ; inline +: TCM_SETITEMSIZE TCM_FIRST 41 + ; inline +: TCM_REMOVEIMAGE TCM_FIRST 42 + ; inline +: TCM_SETPADDING TCM_FIRST 43 + ; inline +: TCM_GETROWCOUNT TCM_FIRST 44 + ; inline +: TCM_GETTOOLTIPS TCM_FIRST 45 + ; inline +: TCM_SETTOOLTIPS TCM_FIRST 46 + ; inline +: TCM_GETCURFOCUS TCM_FIRST 47 + ; inline +: TCM_SETCURFOCUS TCM_FIRST 48 + ; inline +: TCM_SETMINTABWIDTH TCM_FIRST 49 + ; inline +: TCM_DESELECTALL TCM_FIRST 50 + ; inline +: TCM_HIGHLIGHTITEM TCM_FIRST 51 + ; inline +: TCM_SETEXTENDEDSTYLE TCM_FIRST 52 + ; inline +: TCM_GETEXTENDEDSTYLE TCM_FIRST 53 + ; inline +: TCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: TCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: ACM_OPENA WM_USER 100 + ; inline +: ACM_OPENW WM_USER 103 + ; inline +: ACM_PLAY WM_USER 101 + ; inline +: ACM_STOP WM_USER 102 + ; inline +: MCM_FIRST HEX: 1000 ; inline +: MCM_GETCURSEL MCM_FIRST 1 + ; inline +: MCM_SETCURSEL MCM_FIRST 2 + ; inline +: MCM_GETMAXSELCOUNT MCM_FIRST 3 + ; inline +: MCM_SETMAXSELCOUNT MCM_FIRST 4 + ; inline +: MCM_GETSELRANGE MCM_FIRST 5 + ; inline +: MCM_SETSELRANGE MCM_FIRST 6 + ; inline +: MCM_GETMONTHRANGE MCM_FIRST 7 + ; inline +: MCM_SETDAYSTATE MCM_FIRST 8 + ; inline +: MCM_GETMINREQRECT MCM_FIRST 9 + ; inline +: MCM_SETCOLOR MCM_FIRST 10 + ; inline +: MCM_GETCOLOR MCM_FIRST 11 + ; inline +: MCM_SETTODAY MCM_FIRST 12 + ; inline +: MCM_GETTODAY MCM_FIRST 13 + ; inline +: MCM_HITTEST MCM_FIRST 14 + ; inline +: MCM_SETFIRSTDAYOFWEEK MCM_FIRST 15 + ; inline +: MCM_GETFIRSTDAYOFWEEK MCM_FIRST 16 + ; inline +: MCM_GETRANGE MCM_FIRST 17 + ; inline +: MCM_SETRANGE MCM_FIRST 18 + ; inline +: MCM_GETMONTHDELTA MCM_FIRST 19 + ; inline +: MCM_SETMONTHDELTA MCM_FIRST 20 + ; inline +: MCM_GETMAXTODAYWIDTH MCM_FIRST 21 + ; inline +: MCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline +: MCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline +: DTM_FIRST HEX: 1000 ; inline +: DTM_GETSYSTEMTIME DTM_FIRST 1 + ; inline +: DTM_SETSYSTEMTIME DTM_FIRST 2 + ; inline +: DTM_GETRANGE DTM_FIRST 3 + ; inline +: DTM_SETRANGE DTM_FIRST 4 + ; inline +: DTM_SETFORMATA DTM_FIRST 5 + ; inline +: DTM_SETFORMATW DTM_FIRST 50 + ; inline +: DTM_SETMCCOLOR DTM_FIRST 6 + ; inline +: DTM_GETMCCOLOR DTM_FIRST 7 + ; inline +: DTM_GETMONTHCAL DTM_FIRST 8 + ; inline +: DTM_SETMCFONT DTM_FIRST 9 + ; inline +: DTM_GETMCFONT DTM_FIRST 10 + ; inline +: PGM_SETCHILD PGM_FIRST 1 + ; inline +: PGM_RECALCSIZE PGM_FIRST 2 + ; inline +: PGM_FORWARDMOUSE PGM_FIRST 3 + ; inline +: PGM_SETBKCOLOR PGM_FIRST 4 + ; inline +: PGM_GETBKCOLOR PGM_FIRST 5 + ; inline +: PGM_SETBORDER PGM_FIRST 6 + ; inline +: PGM_GETBORDER PGM_FIRST 7 + ; inline +: PGM_SETPOS PGM_FIRST 8 + ; inline +: PGM_GETPOS PGM_FIRST 9 + ; inline +: PGM_SETBUTTONSIZE PGM_FIRST 10 + ; inline +: PGM_GETBUTTONSIZE PGM_FIRST 11 + ; inline +: PGM_GETBUTTONSTATE PGM_FIRST 12 + ; inline +: PGM_GETDROPTARGET CCM_GETDROPTARGET ; inline +: BCM_GETIDEALSIZE BCM_FIRST 1 + ; inline +: BCM_SETIMAGELIST BCM_FIRST 2 + ; inline +: BCM_GETIMAGELIST BCM_FIRST 3 + ; inline +: BCM_SETTEXTMARGIN BCM_FIRST 4 + ; inline +: BCM_GETTEXTMARGIN BCM_FIRST 5 + ; inline +: EM_SETCUEBANNER ECM_FIRST 1 + ; inline +: EM_GETCUEBANNER ECM_FIRST 2 + ; inline +: EM_SHOWBALLOONTIP ECM_FIRST 3 + ; inline +: EM_HIDEBALLOONTIP ECM_FIRST 4 + ; inline +: CB_SETMINVISIBLE CBM_FIRST 1 + ; inline +: CB_GETMINVISIBLE CBM_FIRST 2 + ; inline +: LM_HITTEST WM_USER HEX: 0300 + ; inline +: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline +: LM_SETITEM WM_USER HEX: 0302 + ; inline +: LM_GETITEM WM_USER HEX: 0303 + ; inline From 74fb0ed298c06d7e263adcd8ce8f6d4c6a282d9f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Dec 2007 23:06:11 -0500 Subject: [PATCH 47/82] Oops --- core/flow-chart/flow-chart.factor | 74 ------------------------------- 1 file changed, 74 deletions(-) delete mode 100644 core/flow-chart/flow-chart.factor diff --git a/core/flow-chart/flow-chart.factor b/core/flow-chart/flow-chart.factor deleted file mode 100644 index 5b6cb5f4f5..0000000000 --- a/core/flow-chart/flow-chart.factor +++ /dev/null @@ -1,74 +0,0 @@ -USING: kernel words math inference.dataflow sequences -optimizer.def-use combinators.private namespaces arrays -math.parser assocs prettyprint io strings inference hashtables ; -IN: flow-chart - -GENERIC: flow-chart* ( n word -- value nodes ) - -M: word flow-chart* - 2drop f f ; - -M: compound flow-chart* - word-def swap 1+ [ drop ] map - [ dataflow-with compute-def-use ] keep - first dup used-by prune [ t eq? not ] subset ; - -GENERIC: node-word ( node -- word ) - -M: #call node-word node-param ; - -M: #if node-word drop \ if ; - -M: #dispatch node-word drop \ dispatch ; - -DEFER: flow-chart - -: flow-chart-node ( value node -- ) - [ node-in-d index ] keep - node-word flow-chart , ; - -SYMBOL: pruned - -SYMBOL: nesting - -SYMBOL: max-nesting - -2 max-nesting set - -: flow-chart ( n word -- seq ) - [ - 2dup 2array , - nesting dup inc get max-nesting get > [ - 2drop pruned , - ] [ - flow-chart* dup length 5 > [ - 2drop pruned , - ] [ - [ flow-chart-node ] curry* each - ] if - ] if - ] { } make ; - -: th ( n -- ) - dup number>string write - 100 mod dup 20 > [ 10 mod ] when - H{ { 1 "st" } { 2 "nd" } { 3 "rd" } } at "th" or write ; - -: chart-heading. ( pair -- ) - first2 >r 1+ th " argument to " write r> . ; - -GENERIC# show-chart 1 ( seq n -- ) - -: indent CHAR: \s write ; - -M: sequence show-chart - dup indent - >r unclip chart-heading. r> - 2 + [ show-chart ] curry each ; - -M: word show-chart - dup indent - "... pruned" print ; - -: flow-chart. ( n word -- ) - flow-chart 2 show-chart ; From e58cbb2cdaee14dd0d9b4016e974d62587b7f387 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Dec 2007 11:36:20 -0500 Subject: [PATCH 48/82] : spin swap rot ; --- core/bit-arrays/bit-arrays.factor | 2 +- core/combinators/combinators.factor | 2 +- core/kernel/kernel-docs.factor | 14 +- core/kernel/kernel.factor | 4 +- core/sequences/sequences.factor | 6 +- core/words/words.factor | 2 - extra/cocoa/pasteboard/pasteboard.factor | 2 +- extra/combinators/lib/lib.factor | 2 +- extra/delegate/delegate.factor | 3 - extra/hashtables/lib/lib.factor | 2 +- extra/jamshred/tunnel/tunnel.factor | 2 +- extra/koszul/koszul.factor | 4 +- .../matrices/elimination/elimination.factor | 2 +- extra/prolog/prolog.factor | 2 +- extra/space-invaders/space-invaders.factor | 2 +- extra/ui/gadgets/grid-lines/grid-lines.factor | 4 +- extra/unicode/unicode.factor | 4 +- extra/units/units.factor | 2 +- extra/x/widgets/wm/root/root.factor | 2 +- extra/xml/utilities/utilities.factor | 280 +++++++++--------- 20 files changed, 176 insertions(+), 167 deletions(-) mode change 100644 => 100755 core/bit-arrays/bit-arrays.factor mode change 100644 => 100755 extra/cocoa/pasteboard/pasteboard.factor mode change 100644 => 100755 extra/combinators/lib/lib.factor mode change 100644 => 100755 extra/delegate/delegate.factor mode change 100644 => 100755 extra/hashtables/lib/lib.factor mode change 100644 => 100755 extra/jamshred/tunnel/tunnel.factor mode change 100644 => 100755 extra/koszul/koszul.factor mode change 100644 => 100755 extra/math/matrices/elimination/elimination.factor mode change 100644 => 100755 extra/prolog/prolog.factor mode change 100644 => 100755 extra/space-invaders/space-invaders.factor mode change 100644 => 100755 extra/ui/gadgets/grid-lines/grid-lines.factor mode change 100644 => 100755 extra/unicode/unicode.factor mode change 100644 => 100755 extra/units/units.factor mode change 100644 => 100755 extra/x/widgets/wm/root/root.factor mode change 100644 => 100755 extra/xml/utilities/utilities.factor diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor old mode 100644 new mode 100755 index 185ca0c2d2..d1eb7802ef --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -20,7 +20,7 @@ IN: bit-arrays : (set-bits) ( bit-array n -- ) over length bits>cells -rot [ - swap rot 4 * set-alien-unsigned-4 + spin 4 * set-alien-unsigned-4 ] 2curry each ; inline PRIVATE> diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 2c418768c6..6f39925bd0 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -63,7 +63,7 @@ M: sequence hashcode* next-power-of-2 swap [ nip clone ] curry map ; : distribute-buckets ( assoc initial quot -- buckets ) - swap rot [ length ] keep + spin [ length ] keep [ >r 2dup r> dup first roll call (distribute-buckets) ] each nip ; inline diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index af6acd004b..ae30edc7b8 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -26,6 +26,7 @@ $nl { $subsection swapd } { $subsection rot } { $subsection -rot } +{ $subsection spin } { $subsection roll } { $subsection -roll } "Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:" @@ -37,7 +38,9 @@ $nl { $code ": foo ( m ? n -- m+n/n )" " >r [ r> + ] [ drop r> ] if ; ! This is OK" -} ; +} +"An alternative to using " { $link >r } " and " { $link r> } " is the following:" +{ $subsection dip } ; ARTICLE: "basic-combinators" "Basic combinators" "The following pair of words invoke words and quotations reflectively:" @@ -159,6 +162,7 @@ HELP: tuck ( x y -- y x y ) $shuffle ; HELP: over ( x y -- x y x ) $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ; +HELP: spin $shuffle ; HELP: roll $shuffle ; HELP: -roll $shuffle ; @@ -541,6 +545,14 @@ HELP: 3compose "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations." } ; +HELP: dip +{ $values { "obj" object } { "quot" quotation } } +{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." } +{ $notes "The following are equivalent:" + { $code ">r foo bar r>" } + { $code "[ foo bar ] dip" } +} ; + HELP: while { $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } { $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6fe0a9588c..625c31eba1 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -6,6 +6,8 @@ IN: kernel : version ( -- str ) "0.92" ; foldable ! Stack stuff +: spin ( x y z -- z y x ) swap rot ; inline + : roll ( x y z t -- y z t x ) >r rot r> swap ; inline : -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline @@ -49,7 +51,7 @@ DEFER: if : 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline -: dip ( obj callable -- obj ) swap slip ; inline +: dip ( obj quot -- obj ) swap slip ; inline : keep ( x quot -- x ) over slip ; inline diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index de10e5c2e4..b5955d0197 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -115,7 +115,7 @@ INSTANCE: integer immutable-sequence [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline -: (head) ( seq n -- from to seq ) 0 swap rot ; inline +: (head) ( seq n -- from to seq ) 0 spin ; inline : (tail) ( seq n -- from to seq ) over length rot ; inline @@ -270,7 +270,7 @@ PRIVATE> : tail* ( seq n -- tailseq ) from-end tail ; : copy ( src i dst -- ) - pick length >r 3dup check-copy swap rot 0 r> + pick length >r 3dup check-copy spin 0 r> (copy) drop ; inline M: sequence clone-like @@ -579,7 +579,7 @@ M: sequence <=> : join ( seq glue -- newseq ) [ - 2dup joined-length over new-resizable -rot swap + 2dup joined-length over new-resizable spin [ dup pick push-all ] [ pick push-all ] interleave drop ] keep like ; diff --git a/core/words/words.factor b/core/words/words.factor index baec10a821..23dba982bb 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -94,8 +94,6 @@ M: compound redefined* ( word -- ) - 0 swap rot set-void*-nth f ; + 0 spin set-void*-nth f ; : ?pasteboard-string ( pboard error -- str/f ) over pasteboard-string? [ diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor old mode 100644 new mode 100755 index 047887bcc8..39a04571f7 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -120,7 +120,7 @@ MACRO: ifte ( quot quot quot -- ) : preserving ( predicate -- quot ) dup infer effect-in - dup 1+ swap rot + dup 1+ spin [ , , nkeep , nrot ] bake ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor old mode 100644 new mode 100755 index 5614296305..44da847d9e --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,9 +27,6 @@ M: tuple-class group-words dup [ slot-spec-reader ] map swap [ slot-spec-writer ] map append ; -: spin ( x y z -- z y x ) - swap rot ; - : define-consult-method ( word class quot -- ) pick add spin define-method ; diff --git a/extra/hashtables/lib/lib.factor b/extra/hashtables/lib/lib.factor old mode 100644 new mode 100755 index 1bcd139d9c..9b3932a3a4 --- a/extra/hashtables/lib/lib.factor +++ b/extra/hashtables/lib/lib.factor @@ -9,7 +9,7 @@ IN: hashtables.lib ! set-hash with alternative stack effects -: put-hash* ( table key value -- ) swap rot set-at ; +: put-hash* ( table key value -- ) spin set-at ; : put-hash ( table key value -- table ) swap pick set-at ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor old mode 100644 new mode 100755 index 149170eb53..4d60a65a4a --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -89,7 +89,7 @@ TUPLE: segment number color radius ; rot dup length swap find-nearest-segment ; : nearest-segment-backward ( segments oint start -- segment ) - swapd 1+ 0 swap rot find-nearest-segment ; + swapd 1+ 0 spin find-nearest-segment ; : nearest-segment ( segments oint start-segment -- segment ) #! find the segment nearest to 'oint', and return it. diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor old mode 100644 new mode 100755 index eb15336788..7a97578a9c --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -199,7 +199,7 @@ DEFER: (d) : bigraded-ker/im-d ( bigraded-basis -- seq ) dup length [ over first length [ - >r 2dup r> swap rot (bigraded-ker/im-d) + >r 2dup r> spin (bigraded-ker/im-d) ] map 2nip ] curry* map ; @@ -277,7 +277,7 @@ DEFER: (d) : bigraded-triples ( grid -- triples ) dup length [ over first length [ - >r 2dup r> swap rot bigraded-triple + >r 2dup r> spin bigraded-triple ] map 2nip ] curry* map ; diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor old mode 100644 new mode 100755 index b11ef5ba6b..73f6dd7e96 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -84,7 +84,7 @@ SYMBOL: matrix : basis-vector ( row col# -- ) >r clone r> [ swap nth neg recip ] 2keep - [ 0 swap rot set-nth ] 2keep + [ 0 spin set-nth ] 2keep >r n*v r> matrix get set-nth ; diff --git a/extra/prolog/prolog.factor b/extra/prolog/prolog.factor old mode 100644 new mode 100755 index 0a6a513b97..580bfaf52e --- a/extra/prolog/prolog.factor +++ b/extra/prolog/prolog.factor @@ -79,6 +79,6 @@ SYMBOL: plchoice ] if ; : binding-resolve ( binds name pat -- binds ) - tuck lookup-rule dup backtrace? swap rot add-bindings ; + tuck lookup-rule dup backtrace? spin add-bindings ; : is ( binds val var -- binds ) rot [ set-at ] keep ; diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor old mode 100644 new mode 100755 index 3f695a4f60..aa76f8ec3f --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -293,7 +293,7 @@ M: invaders-gadget draw-gadget* ( gadget -- ) : plot-bitmap-pixel ( bitmap point color -- ) #! point is a {x y}. color is a {r g b}. - swap rot set-bitmap-pixel ; + spin set-bitmap-pixel ; : within ( n a b -- bool ) #! n >= a and n <= b diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor old mode 100644 new mode 100755 index f055ab0df0..8a38737f41 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -14,8 +14,8 @@ SYMBOL: grid-dim : grid-line-from/to ( orientation point -- from to ) half-gap v- - [ half-gap swap rot set-axis ] 2keep - grid-dim get swap rot set-axis ; + [ half-gap spin set-axis ] 2keep + grid-dim get spin set-axis ; : draw-grid-lines ( gaps orientation -- ) grid get rot grid-positions grid get rect-dim add [ diff --git a/extra/unicode/unicode.factor b/extra/unicode/unicode.factor old mode 100644 new mode 100755 index bac768b84c..609b57d4b2 --- a/extra/unicode/unicode.factor +++ b/extra/unicode/unicode.factor @@ -100,7 +100,7 @@ IN: unicode [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; : replace ( seq old new -- newseq ) - swap rot [ 2dup = [ drop over ] when ] map 2nip ; + spin [ 2dup = [ drop over ] when ] map 2nip ; : process-names ( data -- names-hash ) 1 swap (process-data) @@ -382,7 +382,7 @@ SYMBOL: locale ! Just casing locale, or overall? ] if ; inline : insert ( seq quot elt n -- ) - swap rot >r -rot [ swap set-nth ] 2keep r> (insert) ; inline + spin >r -rot [ swap set-nth ] 2keep r> (insert) ; inline : insertion-sort ( seq quot -- ) ! quot is a transformation on elements diff --git a/extra/units/units.factor b/extra/units/units.factor old mode 100644 new mode 100755 index 95f4ed8ef3..f7aad72545 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -69,7 +69,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : d-sq ( d -- d ) dup d* ; : d-recip ( d -- d' ) - >dimensioned< swap rot recip dimension-op> ; + >dimensioned< spin recip dimension-op> ; : d/ ( d d -- d ) d-recip d* ; diff --git a/extra/x/widgets/wm/root/root.factor b/extra/x/widgets/wm/root/root.factor old mode 100644 new mode 100755 index 0ce91d5ebf..f5352a0f07 --- a/extra/x/widgets/wm/root/root.factor +++ b/extra/x/widgets/wm/root/root.factor @@ -74,7 +74,7 @@ dup XKeyEvent-state swap event>keyname 2array ; [ $keymap swap resolve-key-event call ] "grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [ - 3dup name>keysym keysym-to-keycode swap rot + 3dup name>keysym keysym-to-keycode spin False GrabModeAsync GrabModeAsync grab-key ] "set-key-action" !( wm-root modifiers keyname action -- wm-root ) [ diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor old mode 100644 new mode 100755 index 303de4295e..e64b9591a5 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -1,140 +1,140 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences words io assocs -quotations strings parser arrays xml.data xml.writer debugger -splitting ; -IN: xml.utilities - -! * System for words specialized on tag names - -TUPLE: process-missing process tag ; -M: process-missing error. - "Tag <" write - dup process-missing-tag print-name - "> not implemented on process process " write - process-missing-process word-name print ; - -: run-process ( tag word -- ) - 2dup "xtable" word-prop - >r dup name-tag r> at* [ 2nip call ] [ - drop \ process-missing construct-boa throw - ] if ; - -: PROCESS: - CREATE - dup H{ } clone "xtable" set-word-prop - dup [ run-process ] curry define-compound ; parsing - -: TAG: - scan scan-word - parse-definition - swap "xtable" word-prop - rot "/" split [ >r 2dup r> swap set-at ] each 2drop ; - parsing - - -! * Common utility functions - -: build-tag* ( items name -- tag ) - "" swap "" - swap >r { } r> ; - -: build-tag ( item name -- tag ) - >r 1array r> build-tag* ; - -: build-xml ( tag -- xml ) - T{ prolog f "1.0" "iso-8859-1" f } { } rot { } ; - -: children>string ( tag -- string ) - tag-children - dup [ string? ] all? - [ "XML tag unexpectedly contains non-text children" throw ] unless - concat ; - -: children-tags ( tag -- sequence ) - tag-children [ tag? ] subset ; - -: first-child-tag ( tag -- tag ) - tag-children [ tag? ] find nip ; - -! * Utilities for searching through XML documents -! These all work from the outside in, top to bottom. - -: with-delegate ( object quot -- object ) - over clone >r >r delegate r> call r> - [ set-delegate ] keep ; inline - -GENERIC# xml-each 1 ( quot tag -- ) inline -M: tag xml-each - [ call ] 2keep - swap tag-children [ swap xml-each ] curry* each ; -M: object xml-each - call ; -M: xml xml-each - >r delegate r> xml-each ; - -GENERIC# xml-map 1 ( quot tag -- tag ) inline -M: tag xml-map - swap clone over >r swap call r> - swap [ tag-children [ swap xml-map ] curry* map ] keep - [ set-tag-children ] keep ; -M: object xml-map - call ; -M: xml xml-map - swap [ swap xml-map ] with-delegate ; - -: xml-subset ( quot tag -- seq ) ! quot: tag -- ? - V{ } clone rot [ - swap >r [ swap call ] 2keep rot r> - swap [ [ push ] keep ] [ nip ] if - ] xml-each nip ; - -GENERIC# xml-find 1 ( quot tag -- tag ) inline -M: tag xml-find - [ call ] 2keep swap rot [ - f swap - [ nip over >r swap xml-find r> swap dup ] find - 2drop ! leaves result of quot - ] unless nip ; -M: object xml-find - keep f ? ; -M: xml xml-find - >r delegate r> xml-find ; - -GENERIC# xml-inject 1 ( quot tag -- ) inline -M: tag xml-inject - swap [ - swap [ call ] keep - [ xml-inject ] keep - ] change-each ; -M: object xml-inject 2drop ; -M: xml xml-inject >r delegate >r xml-inject ; - -! * Accessing part of an XML document - -: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) - swap [ - dup tag? - [ "id" swap at over = ] - [ drop f ] if - ] xml-find nip ; - -: (get-tag) ( name elem -- ? ) - dup tag? [ names-match? ] [ 2drop f ] if ; - -: tag-named* ( tag name/string -- matching-tag ) - assure-name swap [ dupd (get-tag) ] xml-find nip ; - -: tags-named* ( tag name/string -- tags-seq ) - assure-name swap [ dupd (get-tag) ] xml-subset nip ; - -: tag-named ( tag name/string -- matching-tag ) - ! like get-name-tag but only looks at direct children, - ! not all the children down the tree. - assure-name swap [ (get-tag) ] curry* find nip ; - -: tags-named ( tag name/string -- tags-seq ) - assure-name swap [ (get-tag) ] curry* subset ; - -: assert-tag ( name name -- ) - names-match? [ "Unexpected XML tag found" throw ] unless ; +! Copyright (C) 2005, 2006 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences words io assocs +quotations strings parser arrays xml.data xml.writer debugger +splitting ; +IN: xml.utilities + +! * System for words specialized on tag names + +TUPLE: process-missing process tag ; +M: process-missing error. + "Tag <" write + dup process-missing-tag print-name + "> not implemented on process process " write + process-missing-process word-name print ; + +: run-process ( tag word -- ) + 2dup "xtable" word-prop + >r dup name-tag r> at* [ 2nip call ] [ + drop \ process-missing construct-boa throw + ] if ; + +: PROCESS: + CREATE + dup H{ } clone "xtable" set-word-prop + dup [ run-process ] curry define-compound ; parsing + +: TAG: + scan scan-word + parse-definition + swap "xtable" word-prop + rot "/" split [ >r 2dup r> swap set-at ] each 2drop ; + parsing + + +! * Common utility functions + +: build-tag* ( items name -- tag ) + "" swap "" + swap >r { } r> ; + +: build-tag ( item name -- tag ) + >r 1array r> build-tag* ; + +: build-xml ( tag -- xml ) + T{ prolog f "1.0" "iso-8859-1" f } { } rot { } ; + +: children>string ( tag -- string ) + tag-children + dup [ string? ] all? + [ "XML tag unexpectedly contains non-text children" throw ] unless + concat ; + +: children-tags ( tag -- sequence ) + tag-children [ tag? ] subset ; + +: first-child-tag ( tag -- tag ) + tag-children [ tag? ] find nip ; + +! * Utilities for searching through XML documents +! These all work from the outside in, top to bottom. + +: with-delegate ( object quot -- object ) + over clone >r >r delegate r> call r> + [ set-delegate ] keep ; inline + +GENERIC# xml-each 1 ( quot tag -- ) inline +M: tag xml-each + [ call ] 2keep + swap tag-children [ swap xml-each ] curry* each ; +M: object xml-each + call ; +M: xml xml-each + >r delegate r> xml-each ; + +GENERIC# xml-map 1 ( quot tag -- tag ) inline +M: tag xml-map + swap clone over >r swap call r> + swap [ tag-children [ swap xml-map ] curry* map ] keep + [ set-tag-children ] keep ; +M: object xml-map + call ; +M: xml xml-map + swap [ swap xml-map ] with-delegate ; + +: xml-subset ( quot tag -- seq ) ! quot: tag -- ? + V{ } clone rot [ + swap >r [ swap call ] 2keep rot r> + swap [ [ push ] keep ] [ nip ] if + ] xml-each nip ; + +GENERIC# xml-find 1 ( quot tag -- tag ) inline +M: tag xml-find + [ call ] 2keep spin [ + f swap + [ nip over >r swap xml-find r> swap dup ] find + 2drop ! leaves result of quot + ] unless nip ; +M: object xml-find + keep f ? ; +M: xml xml-find + >r delegate r> xml-find ; + +GENERIC# xml-inject 1 ( quot tag -- ) inline +M: tag xml-inject + swap [ + swap [ call ] keep + [ xml-inject ] keep + ] change-each ; +M: object xml-inject 2drop ; +M: xml xml-inject >r delegate >r xml-inject ; + +! * Accessing part of an XML document + +: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) + swap [ + dup tag? + [ "id" swap at over = ] + [ drop f ] if + ] xml-find nip ; + +: (get-tag) ( name elem -- ? ) + dup tag? [ names-match? ] [ 2drop f ] if ; + +: tag-named* ( tag name/string -- matching-tag ) + assure-name swap [ dupd (get-tag) ] xml-find nip ; + +: tags-named* ( tag name/string -- tags-seq ) + assure-name swap [ dupd (get-tag) ] xml-subset nip ; + +: tag-named ( tag name/string -- matching-tag ) + ! like get-name-tag but only looks at direct children, + ! not all the children down the tree. + assure-name swap [ (get-tag) ] curry* find nip ; + +: tags-named ( tag name/string -- tags-seq ) + assure-name swap [ (get-tag) ] curry* subset ; + +: assert-tag ( name name -- ) + names-match? [ "Unexpected XML tag found" throw ] unless ; From e2f270be70306521bd6f120241a4b4e29f1c1cf0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Dec 2007 12:35:51 -0500 Subject: [PATCH 49/82] Fix cleanup combinator in the case where always-cleanup throws an error --- core/continuations/continuations-tests.factor | 2 +- core/continuations/continuations.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 667d81a30e..360f4750c9 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -104,5 +104,5 @@ SYMBOL: error-counter ] unit-test [ 3 ] [ always-counter get ] unit-test - [ 2 ] [ error-counter get ] unit-test + [ 1 ] [ error-counter get ] unit-test ] with-scope diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 6bb5a50c4b..27ed277c6c 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -127,8 +127,8 @@ PRIVATE> >r (catch) r> ifcc ; inline : cleanup ( try cleanup-always cleanup-error -- ) - >r [ compose (catch) ] keep r> compose - [ dip rethrow ] curry ifcc ; inline + over >r compose [ dip rethrow ] curry + >r (catch) r> ifcc r> call ; inline : attempt-all ( seq quot -- obj ) [ From 2b37b76d65fa8d00c37e9bf39c4a446983f3709f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Dec 2007 12:44:01 -0500 Subject: [PATCH 50/82] Working on profiler --- extra/tools/profiler/profiler-tests.factor | 18 +++++++++++++++++- vm/code_heap.c | 11 +++++------ vm/profiler.c | 14 +++++++------- 3 files changed, 29 insertions(+), 14 deletions(-) mode change 100644 => 100755 extra/tools/profiler/profiler-tests.factor diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor old mode 100644 new mode 100755 index e76e5759b9..c346d9763c --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -1,6 +1,12 @@ IN: temporary USING: tools.profiler tools.test kernel memory math threads -alien tools.profiler.private ; +alien tools.profiler.private sequences ; + +[ t ] [ + \ length profile-counter + 10 [ { } length drop ] times + \ length profile-counter = +] unit-test [ ] [ [ 10 [ data-gc ] times ] profile ] unit-test @@ -26,3 +32,13 @@ alien tools.profiler.private ; ] profile [ 1 ] [ \ foobar profile-counter ] unit-test + +: fooblah { } [ ] each ; + +: foobaz fooblah fooblah ; + +[ foobaz ] profile + +[ 1 ] [ \ foobaz profile-counter ] unit-test + +[ 2 ] [ \ fooblah profile-counter ] unit-test diff --git a/vm/code_heap.c b/vm/code_heap.c index a472431879..ffa5839ab2 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -36,7 +36,7 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) return undefined_symbol; } -static CELL xt_offset; +bool profiling_p_; /* Compute an address to store at a relocation */ INLINE CELL compute_code_rel(F_REL *rel, @@ -56,10 +56,9 @@ INLINE CELL compute_code_rel(F_REL *rel, return CREF(words_start,REL_ARGUMENT(rel)); case RT_XT: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - if(word->compiledp == F) - return (CELL)word->code + sizeof(F_COMPILED); - else - return (CELL)word->code + sizeof(F_COMPILED) + xt_offset; + return (CELL)word->code + + sizeof(F_COMPILED) + + (profiling_p_ ? 0 : word->code->profiler_prologue); case RT_XT_PROFILING: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); return (CELL)word->code + sizeof(F_COMPILED); @@ -140,7 +139,7 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start, { if(reloc_start != literals_start) { - xt_offset = (profiling_p() ? 0 : relocating->profiler_prologue); + profiling_p_ = profiling_p(); F_REL *rel = (F_REL *)reloc_start; F_REL *rel_end = (F_REL *)literals_start; diff --git a/vm/profiler.c b/vm/profiler.c index 79b271dc44..c42c6925a9 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -8,13 +8,13 @@ bool profiling_p(void) void profiling_word(F_WORD *word) { /* If we just enabled the profiler, reset call count */ - // if(profiling_p()) - // word->counter = tag_fixnum(0); - // - // if(word->compiledp == F) - // default_word_xt(word); - // else - // set_word_xt(word,word->code); + if(profiling_p()) + word->counter = tag_fixnum(0); + + if(word->compiledp == F) + default_word_xt(word); + else + set_word_xt(word,word->code); } void set_profiling(bool profiling) From 75695563ca67ce5e1a802fb28d804c610e15b824 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Dec 2007 22:29:59 -0500 Subject: [PATCH 51/82] Fixing interactor (temporarily) --- extra/ui/tools/interactor/interactor-docs.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 10 +++++----- extra/ui/tools/listener/listener.factor | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) mode change 100644 => 100755 extra/ui/tools/interactor/interactor-docs.factor diff --git a/extra/ui/tools/interactor/interactor-docs.factor b/extra/ui/tools/interactor/interactor-docs.factor old mode 100644 new mode 100755 index d2265e38e0..78fb2d652e --- a/extra/ui/tools/interactor/interactor-docs.factor +++ b/extra/ui/tools/interactor/interactor-docs.factor @@ -6,4 +6,4 @@ HELP: interactor $nl "Interactors are created by calling " { $link } "." $nl -"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link parse-interactive } " generic words." } ; +"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 45494124c8..5d7a8b67a5 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -3,9 +3,9 @@ USING: arrays assocs combinators continuations documents ui.tools.workspace hashtables io io.styles kernel math math.vectors models namespaces parser prettyprint quotations -sequences strings threads listener tuples ui.commands -ui.gadgets ui.gadgets.editors -ui.gadgets.presentations ui.gadgets.worlds ui.gestures ; +sequences strings threads listener tuples ui.commands ui.gadgets +ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds +ui.gestures definitions ; IN: ui.tools.interactor TUPLE: interactor @@ -129,7 +129,7 @@ M: interactor stream-read-partial : try-parse ( str interactor -- quot/error/f ) [ [ - [ restore-vars parse ] keep save-vars + [ restore-vars [ parse ] with-compilation-unit ] keep save-vars ] [ >r f swap set-interactor-busy? drop r> dup delegate unexpected-eof? [ drop f ] when @@ -143,7 +143,7 @@ M: interactor stream-read-partial { [ t ] [ handle-parse-error ] } } cond ; -M: interactor parse-interactive +M: interactor stream-read-quot [ save-vars ] keep [ [ handle-interactive ] interactor-yield ] keep restore-vars ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 26910ac7b4..f53e657753 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger threads generator ; +prettyprint listener debugger threads compiler ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; From 529133559f4707b496d9f2d5bf91f016880d05c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Dec 2007 22:30:17 -0500 Subject: [PATCH 52/82] Rename require-each to require-all --- core/vocabs/loader/loader.factor | 6 +++--- extra/tools/browser/browser.factor | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 306f357b72..bb4e47d929 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -84,7 +84,7 @@ SYMBOL: load-help? [ vocab-docs path+ ?run-file ] [ ] [ docs-weren't-loaded ] cleanup - ] keep source-was-loaded + ] keep docs-were-loaded ] [ 2drop ] if ; @@ -152,14 +152,14 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; -: require-each ( seq -- ) +: require-all ( seq -- ) [ [ require ] each ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune require-each ; + append prune require-all ; : refresh ( prefix -- ) to-refresh do-refresh ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index dea4e4251a..d7fbad67d0 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -117,7 +117,7 @@ M: vocab-link summary vocab-summary ; : load-everything ( -- ) all-vocabs-seq [ vocab-name dangerous? not ] subset - require-each ; + require-all ; : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless @@ -137,7 +137,7 @@ M: vocab-link summary vocab-summary ; : load-children ( prefix -- ) all-child-vocabs values concat - require-each ; + require-all ; : vocab-status-string ( vocab -- string ) { From 5378c05508215f3ef9943ac0c719986e1765d17f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Dec 2007 22:44:25 -0500 Subject: [PATCH 53/82] Fix bootstrap --- vm/code_heap.c | 14 +++++++++++--- vm/factor.c | 4 ++-- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/vm/code_heap.c b/vm/code_heap.c index ffa5839ab2..93f078cfda 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -56,9 +56,17 @@ INLINE CELL compute_code_rel(F_REL *rel, return CREF(words_start,REL_ARGUMENT(rel)); case RT_XT: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - return (CELL)word->code - + sizeof(F_COMPILED) - + (profiling_p_ ? 0 : word->code->profiler_prologue); + if(word->code) + { + return (CELL)word->code + + sizeof(F_COMPILED) + + (profiling_p_ ? 0 : word->code->profiler_prologue); + } + else + { + /* Its only NULL in stage 2 early init */ + return 0; + } case RT_XT_PROFILING: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); return (CELL)word->code + sizeof(F_COMPILED); diff --git a/vm/factor.c b/vm/factor.c index 7b74ef6532..76c4acc4b9 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -32,7 +32,7 @@ void default_parameters(F_PARAMETERS *p) /* Do some initialization that we do once only */ void do_stage1_init(void) { - fprintf(stderr,"*** Starting stage 2 early init...\n"); + fprintf(stderr,"*** Stage 2 early init... "); fflush(stderr); jit_compile(userenv[UNDEFINED_ENV]); @@ -60,7 +60,7 @@ void do_stage1_init(void) userenv[STAGE2_ENV] = T; - fprintf(stderr,"*** Finished stage 2 early init\n"); + fprintf(stderr,"done\n"); fflush(stderr); } From 8189e33b2bf034ae05688630067418dcb4e5d085 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 15:05:33 -0500 Subject: [PATCH 54/82] Remove compiler-hook which was just a workaround for the old batch compilation model --- core/bootstrap/stage1.factor | 13 ++-- core/bootstrap/stage2.factor | 5 +- core/compiler/compiler-docs.factor | 87 +++++-------------------- core/compiler/compiler.factor | 9 +-- core/compiler/errors/errors-docs.factor | 48 ++++++++++++++ extra/ui/tools/listener/listener.factor | 3 +- 6 files changed, 74 insertions(+), 91 deletions(-) create mode 100755 core/compiler/errors/errors-docs.factor diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index cda75fedf6..8af1bfdec9 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -13,14 +13,15 @@ vocabs.loader system ; "resource:core/bootstrap/primitives.factor" run-file -! Create a boot quotation +! Create a boot quotation for the target [ - ! Rehash hashtables, since core/tools/image creates them - ! using the host image's hashing algorithms + [ + ! Rehash hashtables, since bootstrap.image creates them + ! using the host image's hashing algorithms + [ hashtable? ] instances [ rehash ] each - [ [ hashtable? ] instances [ rehash ] each ] % - - \ boot , + boot + ] % "math.integers" require "math.floats" require diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index df9e59aec5..3f0fac3882 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -14,7 +14,7 @@ IN: bootstrap.stage2 vm file-name windows? [ >lower ".exe" ?tail drop ] when ".image" append "output-image" set-global - "math compiler tools help ui ui.tools io" "include" set-global + "math tools compiler help ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line @@ -43,9 +43,6 @@ IN: bootstrap.stage2 seq-diff [ "bootstrap." swap append require ] each - init-io - init-stdio - run-bootstrap-init "Compiling remaining words..." print diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 0b2b10bf7b..ccddf97244 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -3,23 +3,14 @@ assocs words.private sequences ; IN: compiler ARTICLE: "compiler-usage" "Calling the optimizing compiler" -"The main entry point to the optimizing compiler is a single word taking a word as input:" +"The main entry points to the optimizing compiler:" { $subsection compile } +{ $subsection recompile } +{ $subsection recompile-all } +"Removing a word's optimized definition:" +{ $subsection decompile } "The optimizing compiler can also compile and call a single quotation:" -{ $subsection compile-call } -"Three utility words for bulk compilation:" -{ $subsection compile-batch } -{ $subsection compile-vocabs } -"Bulk compilation saves compile warnings and errors in a global variable, instead of printing them as they arise:" -{ $subsection compile-errors } -"The warnings and errors can be viewed later:" -{ $subsection :warnings } -{ $subsection :errors } -{ $subsection forget-errors } ; - -ARTICLE: "recompile" "Automatic recompilation" -"When a word is redefined, you can recompile all affected words automatically:" -{ $subsection recompile } ; +{ $subsection compile-call } ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" @@ -27,79 +18,31 @@ ARTICLE: "compiler" "Optimizing compiler" { "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." } { "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." } } -"While the quotation compiler is transparent to the developer, the optimizing compiler is invoked explicitly. It differs in two important ways from the non-optimizing compiler:" -{ $list - { "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." } - { "The optimizing compiler performs " { $emphasis "early binding" } "; if a compiled word " { $snippet "A" } " calls another compiled word " { $snippet "B" } " and " { $snippet "B" } " is subsequently redefined, the compiled definition of " { $snippet "A" } " will still refer to the earlier compiled definition of " { $snippet "B" } ", until " { $snippet "A" } " explicitly recompiled." } -} +"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." { $subsection "compiler-usage" } -{ $subsection "recompile" } ; +{ $subsection "compiler-errors" } ; ABOUT: "compiler" -HELP: compile-error -{ $values { "word" word } { "error" "an error" } } -{ $description "If inside a " { $link compile-batch } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise reports the error to the " { $link stdio } " stream." } ; - -HELP: begin-batch -{ $values { "seq" "a sequence of words" } } -{ $description "Begins batch compilation. Any compile errors reported until a call to " { $link end-batch } " are stored in the " { $link compile-errors } " global variable." } -$low-level-note ; - -HELP: compile-error. -{ $values { "pair" "a " { $snippet "{ word error }" } " pair" } } -{ $description "Prints a compiler error to the " { $link stdio } " stream." } ; - -HELP: (:errors) -{ $values { "seq" "an alist" } } -{ $description "Outputs all serious compiler errors from the most recent compile batch as a sequence of " { $snippet "{ word error }" } " pairs." } ; - -HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile batch to the " { $link stdio } " stream." } ; - -HELP: (:warnings) -{ $values { "seq" "an alist" } } -{ $description "Outputs all ignorable compiler warnings from the most recent compile batch as a sequence of " { $snippet "{ word error }" } " pairs." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile batch to the " { $link stdio } " stream." } ; - -HELP: end-batch -{ $description "Ends batch compilation, printing a summary of the errors and warnings produced to the " { $link stdio } " stream." } -$low-level-note ; - HELP: compile -{ $values { "word" word } } -{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." } ; - -HELP: compile-failed -{ $values { "word" word } { "error" "an error" } } -{ $description "Called when the optimizing compiler fails to compile a word. The word is removed from the set of words pending compilation, and it's un-optimized compiled definition will be used. The error is reported by calling " { $link compile-error } "." } ; - -HELP: compile-batch { $values { "seq" "a sequence of words" } } -{ $description "Compiles a batch of words. Any compile errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." } ; +{ $description "Compiles a set of words. Ignores words which are already compiled." } ; -{ :errors (:errors) :warnings (:warnings) } related-words - -HELP: compile-vocabs -{ $values { "seq" "a sequence of strings" } } -{ $description "Compiles all words which have not been compiled yet from the given vocabularies." } ; +HELP: recompile +{ $values { "seq" "a sequence of words" } } +{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ; HELP: compile-call { $values { "quot" "a quotation" } } { $description "Compiles and runs a quotation." } { $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; -HELP: recompile -{ $description "Recompiles words whose compiled definitions have become out of date as a result of dependent words being redefined." } ; - -HELP: compile-all +HELP: recompile-all { $description "Recompiles all words." } ; -HELP: compile-begins +HELP: decompile { $values { "word" word } } -{ $description "Prints a message stating the word is being compiled, unless we are inside a " { $link compile-batch } "." } ; +{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; HELP: (compile) { $values { "word" word } } diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 0d4812626c..5e8044f804 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -3,14 +3,9 @@ USING: kernel namespaces arrays sequences io inference.backend generator debugger math.parser prettyprint words words.private continuations vocabs assocs alien.compiler dlists optimizer -definitions math compiler.errors ; +definitions math compiler.errors threads ; IN: compiler -SYMBOL: compiler-hook - -: compile-begins ( -- ) - compiler-hook get [ ] or call ; - : compiled-usage ( word -- seq ) #! XXX usage [ word? ] subset ; @@ -28,7 +23,7 @@ SYMBOL: compiler-hook "compiled-effect" set-word-prop ; : (compile) ( word -- ) - compile-begins + yield [ dup word-dataflow optimize >r over dup r> generate ] [ diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor new file mode 100755 index 0000000000..13fc0d3103 --- /dev/null +++ b/core/compiler/errors/errors-docs.factor @@ -0,0 +1,48 @@ +IN: compiler.errors +USING: help.markup help.syntax vocabs.loader words io +quotations ; + +ARTICLE: "compiler-errors" "Compiler warnings and errors" +"The compiler saves compile warnings and errors in a global variable:" +{ $subsection compiler-errors } +"The warnings and errors can be viewed later:" +{ $subsection :warnings } +{ $subsection :errors } +"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:" +{ $link with-compiler-errors } ; + +HELP: compiler-errors +{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ; + +HELP: compiler-error +{ $values { "error" "an error" } { "word" word } } +{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ; + +HELP: compiler-error. +{ $values { "error" "an error" } { "word" word } } +{ $description "Prints a compiler error to the " { $link stdio } " stream." } ; + +HELP: compiler-errors. +{ $values { "errors" "an assoc mapping words to errors" } } +{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ; + +HELP: (:errors) +{ $values { "seq" "an alist" } } +{ $description "Outputs all serious compiler errors from the most recent compile." } ; + +HELP: :errors +{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ; + +HELP: (:warnings) +{ $values { "seq" "an alist" } } +{ $description "Outputs all ignorable compiler warnings from the most recent compile." } ; + +HELP: :warnings +{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ; + +{ :errors (:errors) :warnings (:warnings) } related-words + +HELP: with-compiler-errors +{ $values { "quot" quotation } } +{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." } +{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index f53e657753..4b030844c0 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger threads compiler ; +prettyprint listener debugger threads ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -129,7 +129,6 @@ M: stack-display tool-scroller dup [ ui-listener-hook ] curry listener-hook set dup [ ui-error-hook ] curry error-hook set [ ui-inspector-hook ] curry inspector-hook set - [ yield ] compiler-hook set welcome. listener ] with-stream* ; From 3cd454bfe711ec3ee55f32754bda50b3566fe46e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 15:06:37 -0500 Subject: [PATCH 55/82] Use linux? word now --- core/cpu/ppc/architecture/architecture.factor | 2 +- core/cpu/ppc/ppc.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 core/cpu/ppc/ppc.factor diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index bb0e6cda62..43a2428d42 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -295,7 +295,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ; M: ppc-backend value-structs? #! On Linux/PPC, value structs are passed in the same way #! as reference structs, we just have to make a copy first. - os "linux" = not ; + linux? not ; M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ; diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor old mode 100644 new mode 100755 index 72c4ab335c..0c677cbe51 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -6,7 +6,7 @@ namespaces alien.c-types kernel system combinators ; 4 "longlong" c-type set-c-type-align 4 "ulonglong" c-type set-c-type-align ] } - { [ os "linux" = ] [ + { [ linux? ] [ t "longlong" c-type set-c-type-stack-align? t "ulonglong" c-type set-c-type-stack-align? ] } From fbf992b414dcd01395abcdb4d08d7f7b27642011 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 15:07:22 -0500 Subject: [PATCH 56/82] Call init-io in bootstrap.io --- extra/bootstrap/io/io.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 64d5e929b2..238a971e67 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -1,5 +1,5 @@ USING: system vocabs vocabs.loader kernel combinators -namespaces sequences ; +namespaces sequences io.backend ; IN: bootstrap.io "bootstrap.compiler" vocab [ @@ -10,3 +10,6 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when + +init-io +init-stdio From a8160d74ad0b233a7fd93b7792d2056f798f7efa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 15:08:01 -0500 Subject: [PATCH 57/82] Fix load order issue --- core/alien/syntax/syntax.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 9b7bc6a214..12bf0c5cb9 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays alien alien.c-types alien.structs kernel math -namespaces parser sequences words quotations math.parser -splitting effects prettyprint prettyprint.sections +USING: arrays alien alien.c-types alien.structs alien.arrays +kernel math namespaces parser sequences words quotations +math.parser splitting effects prettyprint prettyprint.sections prettyprint.backend assocs combinators ; IN: alien.syntax From e1be77ee6f9bc57cae357447951385301fb3921f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 15:08:48 -0500 Subject: [PATCH 58/82] Documentation updates --- core/classes/mixin/mixin-docs.factor | 19 ++++- core/classes/predicate/predicate-docs.factor | 6 +- core/classes/union/union-docs.factor | 6 +- core/definitions/definitions-docs.factor | 80 ++++++++++++++++++-- core/definitions/definitions.factor | 12 ++- core/generator/generator-docs.factor | 4 +- core/kernel/kernel-docs.factor | 4 - core/listener/listener-docs.factor | 4 +- core/parser/parser-docs.factor | 40 +--------- core/tuples/tuples-docs.factor | 6 +- core/words/words-docs.factor | 30 +++++++- core/words/words.factor | 1 + extra/help/help-docs.factor | 4 +- extra/tools/annotations/annotations.factor | 5 +- 14 files changed, 151 insertions(+), 70 deletions(-) mode change 100644 => 100755 core/classes/mixin/mixin-docs.factor mode change 100644 => 100755 core/classes/predicate/predicate-docs.factor mode change 100644 => 100755 core/classes/union/union-docs.factor mode change 100644 => 100755 core/listener/listener-docs.factor mode change 100644 => 100755 core/tuples/tuples-docs.factor mode change 100644 => 100755 extra/help/help-docs.factor diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor old mode 100644 new mode 100755 index fedf7c3a29..3646b700b0 --- a/core/classes/mixin/mixin-docs.factor +++ b/core/classes/mixin/mixin-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax help words definitions classes ; IN: classes.mixin ARTICLE: "mixins" "Mixin classes" @@ -11,4 +11,21 @@ ARTICLE: "mixins" "Mixin classes" { $subsection mixin-class } { $subsection mixin-class? } ; +HELP: mixin-class +{ $class-description "The class of mixin classes." } ; + +HELP: define-mixin-class +{ $values { "class" word } } +{ $description "Defines a mixin class. This is the run-time equivalent of " { $link POSTPONE: MIXIN: } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } +{ $side-effects "class" } ; + +HELP: add-mixin-instance +{ $values { "class" class } { "mixin" class } } +{ $description "Defines a class to be an instance of a mixin class. This is the run-time equivalent of " { $link POSTPONE: INSTANCE: } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } +{ $side-effects "class" } ; + +{ mixin-class define-mixin-class add-mixin-instance POSTPONE: MIXIN: POSTPONE: INSTANCE: } related-words + ABOUT: "mixins" diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor old mode 100644 new mode 100755 index 4657671f7f..904807a9fb --- a/core/classes/predicate/predicate-docs.factor +++ b/core/classes/predicate/predicate-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax kernel kernel.private namespaces sequences words arrays layouts help effects math -layouts classes.private classes ; +layouts classes.private classes definitions ; IN: classes.predicate ARTICLE: "predicates" "Predicate classes" @@ -15,7 +15,9 @@ ABOUT: "predicates" HELP: define-predicate-class { $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } } -{ $description "Defines a predicate class." } ; +{ $description "Defines a predicate class. This is the run-time equivalent of " { $link POSTPONE: PREDICATE: } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } +{ $side-effects "class" } ; { predicate-class define-predicate-class POSTPONE: PREDICATE: } related-words diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor old mode 100644 new mode 100755 index 41e761955e..aa620b0d34 --- a/core/classes/union/union-docs.factor +++ b/core/classes/union/union-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax kernel kernel.private namespaces sequences words arrays layouts help effects math -layouts classes.private classes ; +layouts classes.private classes definitions ; IN: classes.union ARTICLE: "unions" "Union classes" @@ -17,7 +17,9 @@ ABOUT: "unions" HELP: define-union-class { $values { "class" class } { "members" "a sequence of classes" } } -{ $description "Defines a union class with specified members." } ; +{ $description "Defines a union class with specified members. This is the run-time equivalent of " { $link POSTPONE: UNION: } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } +{ $side-effects "class" } ; { union-class define-union-class POSTPONE: UNION: } related-words diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index 2a698ca3fa..791e5bef5e 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax words math ; +USING: help.markup help.syntax words math source-files +parser quotations ; IN: definitions ARTICLE: "definition-protocol" "Definition protocol" @@ -18,17 +19,66 @@ $nl { $subsection definer } { $subsection definition } ; -ARTICLE: "definitions" "Definitions" -"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary." -{ $subsection "definition-protocol" } +ARTICLE: "definition-crossref" "Definition cross referencing" "A common cross-referencing system is used to track definition usages:" { $subsection crossref } { $subsection xref } { $subsection unxref } { $subsection delete-xref } -{ $subsection usage } -"Implementations of the definition protocol include pathnames, words, methods, and help articles." -{ $see-also "source-files" "words" "generic" "help-impl" } ; +{ $subsection usage } ; + +ARTICLE: "definition-checking" "Definition sanity checking" +"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." +$nl +"The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":" +{ $code + "USING: io sequences ;" + "IN: a" + ": hello \"Hello\" ;" + ": world \"world\" ;" + ": hello-world hello " " world 3append print ;" +} +"The definitions for " { $snippet "hello" } ", " { $snippet "world" } ", and " { $snippet "hello-world" } " are in the dictionary." +$nl +"Now, after some heavily editing and refactoring, the file looks like this:" +{ $code + "USING: namespaces ;" + "IN: a" + ": hello \"Hello\" % ;" + ": hello-world [ hello " " % world ] \"\" make ;" + ": world \"world\" % ;" +} +"Note that the developer has made a mistake, placing the definition of " { $snippet "world" } " " { $emphasis "after" } " its usage in " { $snippet "hello-world" } "." +$nl +"If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image." +$nl +"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used." +{ $subsection forward-error } +"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image." +$nl +"The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case." +{ $subsection redefine-error } ; + +ARTICLE: "compilation-units" "Compilation units" +"A " { $emphasis "compilation unit" } " scopes a group of related definitions. They are compiled and entered into the system in one atomic operation." +$nl +"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run-time, a compilation unit must be created explicitly:" +{ $subsection with-compilation-unit } +"Words called to associate a definition with a source file location:" +{ $subsection remember-definition } +{ $subsection remember-class } +"Forward reference checking (see " { $link "definition-checking" } "):" +{ $subsection forward-reference? } +"A hook to be called at the end of the compilation unit. If the optimizing compiler is loaded, this compiles new words with the " { $link "compiler" } ":" +{ $subsection recompile-hook } ; + +ARTICLE: "definitions" "Definitions" +"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary. Implementations of the definition protocol include pathnames, words, methods, and help articles." +{ $subsection "definition-protocol" } +{ $subsection "definition-crossref" } +{ $subsection "definition-checking" } +{ $subsection "compilation-units" } +{ $see-also "parser" "source-files" "words" "generic" "help-impl" } ; ABOUT: "definitions" @@ -43,7 +93,13 @@ HELP: set-where HELP: forget { $values { "defspec" "a definition specifier" } } -{ $description "Forgets about a definition. For example, if it is a word, it will be removed from its vocabulary." } ; +{ $description "Forgets about a definition. For example, if it is a word, it will be removed from its vocabulary." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; + +HELP: forget-all +{ $values { "definitions" "a sequence of definition specifiers" } } +{ $description "Forgets every definition in a sequence." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; HELP: uses { $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } @@ -104,3 +160,11 @@ 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: with-compilation-unit +{ $values { "quot" quotation } } +{ $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled and applied atomically." } +{ $notes "Compilation units may be nested. The parser wraps every source file in a compilation unit, so parsing words may define new words without having to perform extra work; to define new words at any other time, you must wrap your defining code with this combinator." } ; + +HELP: recompile-hook +{ $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 9612b97502..76ee8c89f0 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -81,7 +81,17 @@ SYMBOL: recompile-hook : ( -- pair ) { H{ } H{ } } [ clone ] map ; -: with-compilation-unit ( quot -- new-defs ) +TUPLE: no-compilation-unit word ; + +: no-compilation-unit ( word -- * ) + \ no-compilation-unit construct-boa throw ; + +: changed-word ( word -- ) + dup changed-words get + [ no-compilation-unit ] unless* + set-at ; + +: with-compilation-unit ( quot -- ) [ H{ } clone changed-words set new-definitions set diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 558ed2bed8..69262b0470 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -13,9 +13,7 @@ $nl { $subsection define-if-intrinsic } { $subsection define-if-intrinsics } "The main entry point into the code generator:" -{ $subsection generate } -"Primitive compiler interface exported by the Factor VM:" -{ $subsection modify-code-heap } ; +{ $subsection generate } ; ABOUT: "generator" diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index ae30edc7b8..798c0c4b1b 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -564,7 +564,3 @@ $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/listener/listener-docs.factor b/core/listener/listener-docs.factor old mode 100644 new mode 100755 index d4d6053764..62db4a71a7 --- a/core/listener/listener-docs.factor +++ b/core/listener/listener-docs.factor @@ -20,7 +20,7 @@ $nl "The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:" { $subsection listener-hook } "Finally, the multi-line expression reading word can be used independently of the rest of the listener:" -{ $subsection parse-interactive } ; +{ $subsection read-quot } ; ABOUT: "listener" @@ -30,7 +30,7 @@ HELP: quit-flag HELP: listener-hook { $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ; -HELP: parse-interactive +HELP: read-quot { $values { "stream" "an input stream" } { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } { $description "Reads a Factor expression from the stream, possibly spanning more than line. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 6a12632a60..9a2f0a1d22 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -154,44 +154,11 @@ ARTICLE: "parser-files" "Parsing source files" { $subsection parse-file } { $subsection bootstrap-file } "The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions." -$nl -"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." -$nl -"The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":" -{ $code - "USING: io sequences ;" - "IN: a" - ": hello \"Hello\" ;" - ": world \"world\" ;" - ": hello-world hello " " world 3append print ;" -} -"The definitions for " { $snippet "hello" } ", " { $snippet "world" } ", and " { $snippet "hello-world" } " are in the dictionary." -$nl -"Now, after some heavily editing and refactoring, the file looks like this:" -{ $code - "USING: namespaces ;" - "IN: a" - ": hello \"Hello\" % ;" - ": hello-world [ hello " " % world ] \"\" make ;" - ": world \"world\" % ;" -} -"Note that the developer has made a mistake, placing the definition of " { $snippet "world" } " " { $emphasis "after" } " its usage in " { $snippet "hello-world" } "." -$nl -"If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image." -$nl -"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used." -{ $subsection forward-error } -"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image." -$nl -"The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case." -{ $subsection redefine-error } { $see-also "source-files" } ; ARTICLE: "parser-usage" "Reflective parser usage" "The parser can be called on a string:" { $subsection eval } -{ $subsection parse } -{ $subsection parse-fresh } "The parser can also parse from a stream:" { $subsection parse-stream } ; @@ -204,7 +171,8 @@ $nl { $subsection "parser-usage" } "The parser can be extended." { $subsection "parsing-words" } -{ $subsection "parser-lexer" } ; +{ $subsection "parser-lexer" } +{ $see-also "definitions" "definition-checking" } ; ABOUT: "parser" @@ -327,7 +295,7 @@ HELP: still-parsing? HELP: use { $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; -{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: with-with-default-vocabs } related-words +{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: with-file-vocabs with-interactive-vocabs } related-words HELP: in { $var-description "A variable holding the name of the current vocabulary for new definitions." } ; @@ -465,7 +433,7 @@ $parsing-note ; HELP: parse-literal { $values { "accum" vector } { "end" word } { "quot" "a quotation with stack effect " { $snippet "( seq -- obj )" } } } { $description "Parses objects from parser input until " { $snippet "end" } ", applies the quotation to the resulting sequence, and adds the output value to the accumulator." } -{ $examples "This word is used to implement " { $link POSTPONE: C{ } "." } +{ $examples "This word is used to implement " { $link POSTPONE: [ } "." } $parsing-note ; HELP: parse-definition diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor old mode 100644 new mode 100755 index bb6f9e214f..012ea45384 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax kernel tuples.private classes slots quotations words arrays -generic.standard sequences ; +generic.standard sequences definitions ; IN: tuples ARTICLE: "tuple-constructors" "Constructors and slots" @@ -144,7 +144,9 @@ HELP: check-tuple HELP: define-tuple-class { $values { "class" word } { "slots" "a sequence of strings" } } -{ $description "Defines a tuple class with slots named by " { $snippet "slots" } "." } ; +{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run-time equivalent of " { $link POSTPONE: TUPLE: } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } +{ $side-effects "class" } ; { tuple-class define-tuple-class POSTPONE: TUPLE: } related-words diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 98ac00aeb7..9c61bfdbd9 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -11,7 +11,6 @@ $nl "Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "vocabulary-search" } ")." { $subsection create } { $subsection create-in } -{ $subsection gensym } { $subsection lookup } "Words can output their name and vocabulary:" { $subsection word-name } @@ -19,6 +18,14 @@ $nl "Testing if a word object is part of a vocabulary:" { $subsection interned? } ; +ARTICLE: "uninterned-words" "Uninterned words" +"A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." +$nl +"There are several ways of creating an uninterned word:" +{ $subsection } +{ $subsection gensym } +{ $subsection define-temp } ; + ARTICLE: "colon-definition" "Compound definitions" "A compound definition associates a word name with a quotation that is called when the word is executed." { $subsection compound } @@ -143,7 +150,9 @@ 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 word-xt } +"Low-level compiler interface exported by the Factor VM:" +{ $subsection modify-code-heap } ; 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." @@ -159,6 +168,7 @@ $nl { $subsection word } { $subsection word? } { $subsection "interned-words" } +{ $subsection "uninterned-words" } { $subsection "word-definition" } { $subsection "word-props" } { $subsection "word.private" } @@ -238,12 +248,14 @@ $low-level-note HELP: define-symbol { $values { "word" word } } -{ $description "Defines the word to push itself on the stack when executed." } +{ $description "Defines the word to push itself on the stack when executed. This is the run-time equivalent of " { $link POSTPONE: SYMBOL: } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "word" } ; HELP: define-compound { $values { "word" word } { "def" quotation } } -{ $description "Defines the word to call a quotation when executed." } +{ $description "Defines the word to call a quotation when executed. This is the run-time equivalent of " { $link POSTPONE: : } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "word" } ; HELP: reset-props @@ -340,6 +352,7 @@ HELP: define-temp "The following phrases are equivalent:" { $code "[ 2 2 + . ] call" } { $code "[ 2 2 + . ] define-temp execute" } + "This word must be called from inside " { $link with-compilation-unit } "." } ; HELP: quot-uses @@ -382,3 +395,12 @@ HELP: define-inline { $values { "word" word } { "quot" quotation } } { $description "Defines a compound word and makes it " { $link POSTPONE: inline } "." } { $side-effects "word" } ; + +HELP: modify-code-heap ( alist -- ) +{ $values { "alist" "an alist" } } +{ $description "Stores compiled code definitions in the code heap. The alist maps words to the following:" +{ $list + { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." } + { { $snippet "{ code labels rel words literals profiler-prologue }" } " - in this case, a code heap block is allocated with the given data." } +} } +{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; diff --git a/core/words/words.factor b/core/words/words.factor index 23dba982bb..d365ffd1db 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -127,6 +127,7 @@ PRIVATE> : reset-word ( word -- ) { + "unannotated-def" "parsing" "inline" "foldable" "predicating" "reading" "writing" diff --git a/extra/help/help-docs.factor b/extra/help/help-docs.factor old mode 100644 new mode 100755 index fdfa7ddd7b..0323287a9a --- a/extra/help/help-docs.factor +++ b/extra/help/help-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.crossref help.topics help.syntax -definitions io prettyprint inspector help.lint arrays math ; +definitions io prettyprint inspector arrays math ; IN: help ARTICLE: "printing-elements" "Printing markup elements" @@ -160,3 +160,5 @@ HELP: sort-articles HELP: $predicate { $values { "element" "a markup element of the form " { $snippet "{ word }" } } } { $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ; + +USE: help.lint diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 27c427ad25..5406208510 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -4,8 +4,6 @@ USING: kernel words parser io inspector quotations sequences prettyprint continuations effects definitions ; IN: tools.annotations -r dup word-def r> call define-compound ] with-compilation-unit ; inline @@ -42,8 +41,6 @@ IN: tools.annotations rot [ leaving ] curry swapd 3append ; -PRIVATE> - : watch ( word -- ) dup [ (watch) ] annotate ; From 13c058870eca1ac09247b1a2670d8a29ddab39ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 15:40:57 -0500 Subject: [PATCH 59/82] Fix bootstrap.help --- core/parser/parser.factor | 13 +++++++------ extra/bootstrap/help/help.factor | 4 +--- 2 files changed, 8 insertions(+), 9 deletions(-) mode change 100644 => 100755 extra/bootstrap/help/help.factor diff --git a/core/parser/parser.factor b/core/parser/parser.factor index d3efd54904..6a0b5a5fad 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -350,7 +350,6 @@ SYMBOL: bootstrap-syntax [ "scratchpad" in set { - "scratchpad" "arrays" "assocs" "combinators" @@ -358,11 +357,14 @@ SYMBOL: bootstrap-syntax "continuations" "debugger" "definitions" + "editors" "generic" + "help" "inspector" "io" "io.files" "kernel" + "listener" "math" "memory" "namespaces" @@ -372,17 +374,16 @@ SYMBOL: bootstrap-syntax "sorting" "strings" "syntax" - "vocabs" - "vocabs.loader" - "words" "tools.annotations" "tools.crossref" "tools.memory" "tools.profiler" "tools.test" "tools.time" - "editors" - "listener" + "vocabs" + "vocabs.loader" + "words" + "scratchpad" } set-use call ] with-scope ; inline diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor old mode 100644 new mode 100755 index 003c3a9855..a7a4408ed1 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -17,8 +17,6 @@ IN: bootstrap.help ] if ] each - "help.handbook" require - - global [ "help" use+ ] bind ; + "help.handbook" require ; load-help From 78ae930a33eb44091c701591f470f5a17d115c3f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 16:09:21 -0500 Subject: [PATCH 60/82] Documentation updates --- core/alien/alien-docs.factor | 13 ++++++++++++- core/classes/mixin/mixin-docs.factor | 4 ++-- core/classes/predicate/predicate-docs.factor | 2 +- core/classes/union/union-docs.factor | 2 +- core/compiler/compiler.factor | 8 +++++--- core/debugger/debugger.factor | 3 +++ core/definitions/definitions-docs.factor | 17 ++++++++++++++--- core/parser/parser-docs.factor | 12 ++++++++++-- core/syntax/syntax-docs.factor | 19 ++++++++++++++++++- core/tuples/tuples-docs.factor | 2 +- core/words/words-docs.factor | 6 +++--- 11 files changed, 70 insertions(+), 18 deletions(-) mode change 100644 => 100755 core/alien/alien-docs.factor diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor old mode 100644 new mode 100755 index 259d78f67f..089091bec5 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -70,7 +70,18 @@ HELP: load-library HELP: add-library { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } { $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." } -{ $examples { $code "\"gif\" \"libgif.so\" \"cdecl\" add-library" } } ; +{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work." +$nl +"Instead, " { $link add-library } " calls must either be placed in different source files from those that use that library, or alternatively, " { $link "syntax-immediate" } " can be used to load the library before compilation." } +{ $examples "Here is a typical usage of " { $link add-library } ":" +{ $code + "<< \"freetype\" {" + " { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" + " { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" + " { [ t ] [ drop ] }" + "} cond >>" +} +"Note the parse time evaluation with " { $link POSTPONE: << } "." } ; HELP: alien-invoke-error { $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor index 3646b700b0..b0d02c8ecc 100755 --- a/core/classes/mixin/mixin-docs.factor +++ b/core/classes/mixin/mixin-docs.factor @@ -16,13 +16,13 @@ HELP: mixin-class HELP: define-mixin-class { $values { "class" word } } -{ $description "Defines a mixin class. This is the run-time equivalent of " { $link POSTPONE: MIXIN: } "." } +{ $description "Defines a mixin class. This is the run time equivalent of " { $link POSTPONE: MIXIN: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "class" } ; HELP: add-mixin-instance { $values { "class" class } { "mixin" class } } -{ $description "Defines a class to be an instance of a mixin class. This is the run-time equivalent of " { $link POSTPONE: INSTANCE: } "." } +{ $description "Defines a class to be an instance of a mixin class. This is the run time equivalent of " { $link POSTPONE: INSTANCE: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "class" } ; diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor index 904807a9fb..2f340b353e 100755 --- a/core/classes/predicate/predicate-docs.factor +++ b/core/classes/predicate/predicate-docs.factor @@ -15,7 +15,7 @@ ABOUT: "predicates" HELP: define-predicate-class { $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } } -{ $description "Defines a predicate class. This is the run-time equivalent of " { $link POSTPONE: PREDICATE: } "." } +{ $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "class" } ; diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor index aa620b0d34..ce5ad7b6fb 100755 --- a/core/classes/union/union-docs.factor +++ b/core/classes/union/union-docs.factor @@ -17,7 +17,7 @@ ABOUT: "unions" HELP: define-union-class { $values { "class" class } { "members" "a sequence of classes" } } -{ $description "Defines a union class with specified members. This is the run-time equivalent of " { $link POSTPONE: UNION: } "." } +{ $description "Defines a union class with specified members. This is the run time equivalent of " { $link POSTPONE: UNION: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "class" } ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 5e8044f804..a18b832725 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -23,7 +23,6 @@ IN: compiler "compiled-effect" set-word-prop ; : (compile) ( word -- ) - yield [ dup word-dataflow optimize >r over dup r> generate ] [ @@ -37,8 +36,11 @@ IN: compiler [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ; : compile-loop ( assoc -- ) - dup assoc-empty? - [ drop ] [ dup delete-any (compile) compile-loop ] if ; + dup assoc-empty? [ drop ] [ + dup delete-any (compile) + yield + compile-loop + ] if ; : recompile ( words -- ) [ diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index a085eea0cb..7c973053da 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -227,3 +227,6 @@ M: forward-error error. M: undefined summary drop "Calling a deferred word before it has been defined" ; + +M: no-compilation-unit summary + drop "Defining a word outside of a compilation unit" ; diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index 791e5bef5e..f8eeafd505 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -62,7 +62,9 @@ $nl ARTICLE: "compilation-units" "Compilation units" "A " { $emphasis "compilation unit" } " scopes a group of related definitions. They are compiled and entered into the system in one atomic operation." $nl -"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run-time, a compilation unit must be created explicitly:" +"Words defined in a compilation unit may not be called until the compilation unit is finished. The parser detects this case for parsing words and throws a " { $link staging-violation } "; calling any other word from within its own compilation unit throws an " { $link undefined } " error." +$nl +"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:" { $subsection with-compilation-unit } "Words called to associate a definition with a source file location:" { $subsection remember-definition } @@ -163,8 +165,17 @@ HELP: forward-error HELP: with-compilation-unit { $values { "quot" quotation } } -{ $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled and applied atomically." } -{ $notes "Compilation units may be nested. The parser wraps every source file in a compilation unit, so parsing words may define new words without having to perform extra work; to define new words at any other time, you must wrap your defining code with this combinator." } ; +{ $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." } +{ $notes "Compilation units may be nested." +$nl +"The parser wraps every source file in a compilation unit, so parsing words may define new words without having to perform extra work; to define new words at any other time, you must wrap your defining code with this combinator." +$nl +"Since compilation is relatively expensive, you should try to batch up as many definitions into one compilation unit as possible." } ; HELP: recompile-hook { $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ; + +HELP: no-compilation-unit +{ $values { "word" word } } +{ $description "Throws a " { $link no-compilation-unit } " error." } +{ $error-description "Thrown when an attempt is made to define a word outside of a " { $link with-compilation-unit } " combinator." } ; diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 9a2f0a1d22..ec061d0046 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -121,6 +121,8 @@ $nl { $code ": hello \"Hello world\" print ; parsing" } "Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." $nl +"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:" +{ $link staging-violation } "Tools for implementing parsing words:" { $subsection "reading-ahead" } { $subsection "parsing-word-nest" } @@ -456,8 +458,8 @@ HELP: parse-fresh HELP: eval { $values { "str" string } } -{ $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." } ; +{ $description "Parses Factor source code from a string, and calls the resulting quotation." } +{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; HELP: outside-usages { $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } } @@ -505,3 +507,9 @@ HELP: bootstrap-file HELP: eval>string { $values { "str" string } { "output" string } } { $description "Evaluates the Factor code in " { $snippet "str" } " with the " { $link stdio } " stream rebound to a string output stream, then outputs the resulting string." } ; + +HELP: staging-violation +{ $values { "word" word } } +{ $description "Throws a " { $link staging-violation } " error." } +{ $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." } +{ $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index a947362617..9f6509989b 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -28,6 +28,11 @@ ARTICLE: "syntax-comments" "Comments" { $subsection POSTPONE: ! } { $subsection POSTPONE: #! } ; +ARTICLE: "syntax-immediate" "Parse time evaluation" +"Code can be evaluated at parse time. This is a rarely-used feature; one use-case is " { $link "loading-libs" } ", where you want to execute some code before the words in a source file are compiled." +{ $subsection POSTPONE: << } +{ $subsection POSTPONE: >> } ; + ARTICLE: "syntax-integers" "Integer syntax" "The printed representation of an integer consists of a sequence of digits, optionally prefixed by a sign." { $code @@ -173,7 +178,8 @@ ARTICLE: "syntax" "Syntax" "Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "." { $subsection "parser-algorithm" } { $subsection "syntax-comments" } -{ $subsection "syntax-literals" } ; +{ $subsection "syntax-literals" } +{ $subsection "syntax-immediate" } ; ABOUT: "syntax" @@ -567,3 +573,14 @@ HELP: PRIVATE> { $description "Marks the end of a block of private word definitions." } ; { POSTPONE: } related-words + +HELP: << +{ $syntax "<< ... >>" } +{ $description "Evaluates some code at parse time." } +{ $notes "Calling words defined in the same source file at parse time is prohibited; see compilation unit as where it was defined; see " { $link "compilation-units" } "." } ; + +HELP: >> +{ $syntax ">>" } +{ $description "Marks the end of a parse time code block." } ; + +{ POSTPONE: << POSTPONE: >> } related-words diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 012ea45384..49a0353dc5 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -144,7 +144,7 @@ HELP: check-tuple HELP: define-tuple-class { $values { "class" word } { "slots" "a sequence of strings" } } -{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run-time equivalent of " { $link POSTPONE: TUPLE: } "." } +{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "class" } ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 9c61bfdbd9..82dce8a241 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -54,7 +54,7 @@ ARTICLE: "primitives" "Primitives" { $subsection primitive? } ; ARTICLE: "deferred" "Deferred words and mutual recursion" -"Words cannot be referenced before they are defined; that is, source files must order definitions in a strictly bottom-up fashion. This is done to simplify the implementation, facilitate better parse-time checking and remove some odd corner cases; it also encourages better coding style. Sometimes this restriction gets in the way, for example when defining mutually-recursive words; one way to get around this limitation is to make a forward definition." +"Words cannot be referenced before they are defined; that is, source files must order definitions in a strictly bottom-up fashion. This is done to simplify the implementation, facilitate better parse time checking and remove some odd corner cases; it also encourages better coding style. Sometimes this restriction gets in the way, for example when defining mutually-recursive words; one way to get around this limitation is to make a forward definition." { $subsection POSTPONE: DEFER: } "The class of forward word definitions:" { $subsection deferred } @@ -248,13 +248,13 @@ $low-level-note HELP: define-symbol { $values { "word" word } } -{ $description "Defines the word to push itself on the stack when executed. This is the run-time equivalent of " { $link POSTPONE: SYMBOL: } "." } +{ $description "Defines the word to push itself on the stack when executed. This is the run time equivalent of " { $link POSTPONE: SYMBOL: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "word" } ; HELP: define-compound { $values { "word" word } { "def" quotation } } -{ $description "Defines the word to call a quotation when executed. This is the run-time equivalent of " { $link POSTPONE: : } "." } +{ $description "Defines the word to call a quotation when executed. This is the run time equivalent of " { $link POSTPONE: : } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "word" } ; From af41a0efe76b041f916eb47a935b0efdc627dc8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 16:54:01 -0500 Subject: [PATCH 61/82] Re-implement callstack>array --- vm/callstack.c | 21 ++++++---- vm/callstack.h | 0 vm/quotations.c | 102 ++++++++++++++++++++++++++++++++++++++++++++++++ vm/quotations.h | 1 + 4 files changed, 116 insertions(+), 8 deletions(-) mode change 100644 => 100755 vm/callstack.h diff --git a/vm/callstack.c b/vm/callstack.c index 8c11b15aae..762dabe07e 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -123,9 +123,20 @@ F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) CELL frame_scan(F_STACK_FRAME *frame) { - //XXX if(frame_type(frame) == QUOTATION_TYPE) - return tag_fixnum(0); //UNAREF(UNTAG(frame->array),frame->scan)); + { + CELL quot = frame_executing(frame); + if(quot == F) + return F; + else + { + XT return_addr = FRAME_RETURN_ADDRESS(frame); + XT quot_xt = (XT)(frame_code(frame) + 1); + + return tag_fixnum(quot_code_offset_to_scan( + quot,(CELL)(return_addr - quot_xt))); + } + } else return F; } @@ -214,14 +225,8 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot) F_STACK_FRAME *inner = innermost_stack_frame(callstack); type_check(QUOTATION_TYPE,frame_executing(inner)); - //XXX - - //CELL scan = inner->scan - inner->array; CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt; - //inner->array = quot->array; - //inner->scan = quot->array + scan; - inner->xt = quot->xt; FRAME_RETURN_ADDRESS(inner) = quot->xt + offset; diff --git a/vm/callstack.h b/vm/callstack.h old mode 100644 new mode 100755 diff --git a/vm/quotations.c b/vm/quotations.c index 791802bd0d..2468e58822 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -246,6 +246,108 @@ void jit_compile(CELL quot) UNREGISTER_ROOT(quot); } +/* Crappy code duplication. If C had closures (not just function pointers) +it would be easy to get rid of, but I can't think of a good way to deal +with it right now that doesn't involve lots of boilerplate that would be +worse than the duplication itself (eg, putting all state in some global +struct.) */ +#define COUNT(name,scan) \ + { \ + if(offset == 0) return scan - 1; \ + offset -= array_capacity(code_to_emit(name)) * code_format; \ + } + +F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) +{ + CELL code_format = compiled_code_format(); + + CELL array = untag_quotation(quot)->array; + + bool stack_frame = jit_stack_frame_p(untag_object(array)); + + if(stack_frame) + COUNT(JIT_PROLOG,0) + + CELL i; + CELL length = array_capacity(untag_object(array)); + bool tail_call = false; + + for(i = 0; i < length; i++) + { + CELL obj = array_nth(untag_object(array),i); + F_WORD *word; + + switch(type_of(obj)) + { + case WORD_TYPE: + word = untag_object(obj); + + if(i == length - 1) + { + if(stack_frame) + COUNT(JIT_EPILOG,i); + + if(type_of(word->def) == FIXNUM_TYPE) + COUNT(JIT_WORD_PRIMITIVE_JUMP,i) + else + COUNT(JIT_WORD_JUMP,i) + + tail_call = true; + } + else + { + if(type_of(word->def) == FIXNUM_TYPE) + COUNT(JIT_WORD_PRIMITIVE_CALL,i) + else + COUNT(JIT_WORD_CALL,i) + } + break; + case WRAPPER_TYPE: + COUNT(JIT_PUSH_LITERAL,i) + break; + case QUOTATION_TYPE: + if(jit_fast_if_p(untag_object(array),i)) + { + if(stack_frame) + COUNT(JIT_EPILOG,i) + + i += 2; + + COUNT(JIT_IF_JUMP,i) + + tail_call = true; + break; + } + case ARRAY_TYPE: + if(jit_fast_dispatch_p(untag_object(array),i)) + { + if(stack_frame) + COUNT(JIT_EPILOG,i) + + i++; + + COUNT(JIT_DISPATCH,i) + + tail_call = true; + break; + } + default: + COUNT(JIT_PUSH_LITERAL,i) + break; + } + } + + if(!tail_call) + { + if(stack_frame) + COUNT(JIT_EPILOG,length) + + COUNT(JIT_RETURN,length) + } + + return -1; +} + F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) { stack_chain->callstack_top = stack; diff --git a/vm/quotations.h b/vm/quotations.h index c4c22e2153..0466ff1f9b 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,6 +1,7 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); void jit_compile(CELL quot); F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); +F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); void uncurry(CELL obj); DECLARE_PRIMITIVE(curry); DECLARE_PRIMITIVE(array_to_quotation); From 64b06f059aaedc058ceb10d4c35ea022c6f5baf4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 17:14:15 -0500 Subject: [PATCH 62/82] Unit test fixes --- core/bootstrap/image/image-tests.factor | 3 ++- core/classes/classes-tests.factor | 2 +- core/generic/generic-tests.factor | 2 -- core/inference/class/class-tests.factor | 2 +- core/parser/parser.factor | 12 +++++++++--- core/prettyprint/prettyprint.factor | 4 ++-- core/tuples/tuples-tests.factor | 6 ++++++ extra/help/definitions/definitions-tests.factor | 8 +++----- extra/help/definitions/definitions.factor | 2 -- extra/help/syntax/syntax-tests.factor | 4 +--- extra/ui/gadgets/gadgets-docs.factor | 2 -- extra/ui/tools/interactor/interactor.factor | 2 +- extra/ui/tools/walker/walker-tests.factor | 2 +- 13 files changed, 27 insertions(+), 24 deletions(-) mode change 100644 => 100755 extra/help/definitions/definitions.factor mode change 100644 => 100755 extra/help/syntax/syntax-tests.factor mode change 100644 => 100755 extra/ui/gadgets/gadgets-docs.factor diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index 901d23e24d..ea533f0d6f 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,5 +1,6 @@ IN: temporary -USING: bootstrap.image tools.test.infer ; +USING: bootstrap.image bootstrap.image.private +tools.test.inference ; \ ' must-infer \ write-image must-infer diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 2b82c7e0d6..00bf3262aa 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -62,7 +62,7 @@ UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test ! Test generic see and parsing -[ "IN: temporary\nSYMBOL: bah\n\nUNION: bah fixnum alien ;\n" ] +[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] [ [ \ bah see ] string-out ] unit-test ! Test redefinition of classes diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index a66e24956e..5a16f40eb5 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -120,8 +120,6 @@ TUPLE: delegating ; [ t ] [ \ + math-generic? ] unit-test -[ "SYMBOL: not-a-class C: not-a-class ;" eval ] unit-test-fails - ! Test math-combination [ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test [ [ >float ] ] [ \ float \ real math-upgrade ] unit-test diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 1cfae3301e..c7289b110a 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -3,7 +3,7 @@ USING: arrays math.private kernel math compiler inference inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private -slots.private combinators ; +slots.private combinators definitions ; ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6a0b5a5fad..4503d2f2e0 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -265,8 +265,9 @@ M: staging-violation summary "A parsing word cannot be used in the same file it is defined in." ; : execute-parsing ( word -- ) - dup - new-definitions get first key? [ staging-violation ] when + new-definitions get [ + dupd first key? [ staging-violation ] when + ] when* execute ; : parse-step ( accum end -- accum ? ) @@ -300,6 +301,9 @@ SYMBOL: lexer-factory : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; +: parse ( str -- quot ) + [ string-lines parse-lines ] with-compilation-unit ; + ! Parsing word utilities : parse-effect ( -- effect ) ")" parse-tokens { "--" } split1 dup [ @@ -421,7 +425,9 @@ SYMBOL: bootstrap-syntax file get source-file-path = ] assoc-subset ; -: removed-definitions ( -- definitions ) new-definitions get old-definitions get [ first2 union ] 2apply diff ; +: removed-definitions ( -- definitions ) + new-definitions old-definitions + [ get first2 union ] 2apply diff ; : smudged-usage ( -- usages referenced removed ) removed-definitions filter-moved keys [ diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 420d3bedbc..cc19a67bfa 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -256,7 +256,7 @@ M: builtin-class see-class* : see-class ( class -- ) dup class? [ - nl [ dup see-class* ] with-pprint nl + dup seeing-word dup see-class* ] when drop ; : see-methods ( generic -- seq ) @@ -265,7 +265,7 @@ M: builtin-class see-class* M: word see [ - dup see-class* + dup see-class dup class? over symbol? and not [ dup (see) ] when ] with-use nl [ diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index bdb8b61299..62bbc7ace5 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -233,3 +233,9 @@ C: erg's-reshape-problem [ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test + +[ t ] [ + [ + "IN: temporary SYMBOL: not-a-class C: not-a-class" eval + ] catch [ check-tuple? ] is? +] unit-test diff --git a/extra/help/definitions/definitions-tests.factor b/extra/help/definitions/definitions-tests.factor index a07789ddfd..836f82a306 100755 --- a/extra/help/definitions/definitions-tests.factor +++ b/extra/help/definitions/definitions-tests.factor @@ -1,13 +1,11 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files -assocs namespaces words io ; +assocs namespaces words io sequences ; IN: temporary [ ] [ \ + >link see ] unit-test [ - file-vocabs - [ 4 ] [ "IN: temporary USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop @@ -34,9 +32,9 @@ IN: temporary "hello" "temporary" lookup "help" word-prop ] unit-test - [ [ ] ] [ "IN: temporary USING: help.syntax ; : xxx ; HELP: xxx ;" parse ] unit-test + [ ] [ "IN: temporary USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test [ ] [ "xxx" "temporary" lookup help ] unit-test [ ] [ "xxx" "temporary" lookup >link synopsis print ] unit-test -] with-scope +] with-file-vocabs diff --git a/extra/help/definitions/definitions.factor b/extra/help/definitions/definitions.factor old mode 100644 new mode 100755 index 76940b50ae..eee2bcd19c --- a/extra/help/definitions/definitions.factor +++ b/extra/help/definitions/definitions.factor @@ -16,8 +16,6 @@ M: link forget link-name remove-article ; M: link definition article-content ; -M: link see (see) ; - M: link synopsis* \ ARTICLE: pprint-word dup link-name pprint* diff --git a/extra/help/syntax/syntax-tests.factor b/extra/help/syntax/syntax-tests.factor old mode 100644 new mode 100755 index 74e7d296c4..136313c2ef --- a/extra/help/syntax/syntax-tests.factor +++ b/extra/help/syntax/syntax-tests.factor @@ -2,8 +2,6 @@ IN: temporary USING: tools.test parser vocabs help.syntax namespaces ; [ - file-vocabs - [ "foobar" ] [ "IN: temporary USE: help.syntax ABOUT: \"foobar\"" eval "temporary" vocab vocab-help @@ -20,4 +18,4 @@ USING: tools.test parser vocabs help.syntax namespaces ; "IN: temporary USE: help.syntax ABOUT: xyz" eval "temporary" vocab vocab-help ] unit-test -] with-scope +] with-file-vocabs diff --git a/extra/ui/gadgets/gadgets-docs.factor b/extra/ui/gadgets/gadgets-docs.factor old mode 100644 new mode 100755 index 1132ea8d66..fd06d02ec0 --- a/extra/ui/gadgets/gadgets-docs.factor +++ b/extra/ui/gadgets/gadgets-docs.factor @@ -306,5 +306,3 @@ $nl { $subsection control-value } { $subsection set-control-value } { $see-also "models" } ; - -ABOUT: "ui-control-impl" diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 5d7a8b67a5..a420bf278f 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -129,7 +129,7 @@ M: interactor stream-read-partial : try-parse ( str interactor -- quot/error/f ) [ [ - [ restore-vars [ parse ] with-compilation-unit ] keep save-vars + [ restore-vars parse ] keep save-vars ] [ >r f swap set-interactor-busy? drop r> dup delegate unexpected-eof? [ drop f ] when diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index 53903a27b3..a23b629d1e 100755 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -34,7 +34,7 @@ f dup [ workspace-listener listener-gadget-input "ok" on - parse-interactive + stream-read-quot "c" get continue-with ] in-thread drop From 18eb8e2bd38fc53109cc80c29650c74bbd14bb20 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 21:15:59 -0500 Subject: [PATCH 63/82] Clean up interactor gadget --- core/listener/listener.factor | 7 +- core/parser/parser.factor | 3 - extra/ui/gadgets/editors/editors.factor | 7 +- extra/ui/tools/interactor/interactor.factor | 94 ++++++++++----------- extra/ui/tools/listener/listener.factor | 4 +- extra/ui/tools/operations/operations.factor | 2 +- 6 files changed, 57 insertions(+), 60 deletions(-) diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 6f94d92d93..eb912c47c9 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -14,10 +14,11 @@ SYMBOL: listener-hook GENERIC: stream-read-quot ( stream -- quot/f ) +: parse-lines-interactive ( lines -- quot/f ) + [ parse-lines in get ] with-compilation-unit in set ; + : read-quot-step ( lines -- quot/f ) - [ - [ parse-lines in get ] with-compilation-unit in set - ] catch { + [ parse-lines-interactive ] catch { { [ dup delegate unexpected-eof? ] [ 2drop f ] } { [ dup not ] [ drop ] } { [ t ] [ rethrow ] } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 4503d2f2e0..2d3f4b9cb2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -301,9 +301,6 @@ SYMBOL: lexer-factory : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; -: parse ( str -- quot ) - [ string-lines parse-lines ] with-compilation-unit ; - ! Parsing word utilities : parse-effect ( -- effect ) ")" parse-tokens { "--" } split1 dup [ diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 2d447db1e9..5636800c1e 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -62,10 +62,13 @@ M: editor ungraft* : editor-mark* ( editor -- loc ) editor-mark model-value ; +: set-caret ( loc editor -- ) + [ gadget-model validate-loc ] keep + editor-caret set-model ; + : change-caret ( editor quot -- ) over >r >r dup editor-caret* swap gadget-model r> call r> - [ gadget-model validate-loc ] keep - editor-caret set-model ; inline + set-caret ; inline : mark>caret ( editor -- ) dup editor-caret* swap editor-mark set-model ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index a420bf278f..fe8c85d04b 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -11,20 +11,9 @@ IN: ui.tools.interactor TUPLE: interactor history output continuation quot busy? -vars +use help ; -: interactor-use ( interactor -- seq ) - use swap interactor-vars at ; - -: word-at-loc ( loc interactor -- word ) - over [ - [ gadget-model T{ one-word-elt } elt-string ] keep - interactor-use assoc-stack - ] [ - 2drop f - ] if ; - : init-caret-help ( interactor -- ) dup editor-caret 100 swap set-interactor-help ; @@ -47,6 +36,14 @@ M: interactor ungraft* dup dup interactor-help remove-connection delegate ungraft* ; +: word-at-loc ( loc interactor -- word ) + over [ + [ gadget-model T{ one-word-elt } elt-string ] keep + interactor-use assoc-stack + ] [ + 2drop f + ] if ; + M: interactor model-changed 2dup interactor-help eq? [ swap model-value over word-at-loc swap show-summary @@ -70,34 +67,36 @@ M: interactor model-changed t over set-interactor-busy? interactor-continuation schedule-thread-with ; -: interactor-finish ( obj interactor -- ) +: interactor-finish ( interactor -- ) [ editor-string ] keep [ interactor-input. ] 2keep [ add-interactor-history ] keep - dup gadget-model clear-doc - interactor-continue ; - -: interactor-eval ( interactor -- ) - [ - [ editor-string ] keep dup interactor-quot call - ] in-thread drop ; + gadget-model clear-doc ; : interactor-eof ( interactor -- ) - f swap interactor-continue ; + dup interactor-busy? [ + f over interactor-continue + ] unless drop ; : evaluate-input ( interactor -- ) - dup interactor-busy? [ drop ] [ interactor-eval ] if ; + dup interactor-busy? [ + [ + [ control-value ] keep interactor-continue + ] in-thread + ] unless drop ; -: interactor-yield ( interactor quot -- obj ) - over set-interactor-quot +: interactor-yield ( interactor -- obj ) f over set-interactor-busy? [ set-interactor-continuation stop ] curry callcc1 ; M: interactor stream-readln - [ interactor-finish ] interactor-yield ; + [ interactor-yield ] keep interactor-finish first ; : interactor-call ( quot interactor -- ) - 2dup interactor-input. interactor-continue ; + dup interactor-busy? [ + 2dup interactor-input. + 2dup interactor-continue + ] unless 2drop ; M: interactor stream-read swap dup zero? [ @@ -109,44 +108,41 @@ M: interactor stream-read M: interactor stream-read-partial stream-read ; -: save-vars ( interactor -- ) - { use in stdio lexer-factory } [ dup get ] H{ } map>assoc - swap set-interactor-vars ; - -: restore-vars ( interactor -- ) - namespace swap interactor-vars update ; +: save-use ( interactor -- ) + use get swap set-interactor-use ; : go-to-error ( interactor error -- ) dup parse-error-line 1- swap parse-error-col 2array - over [ gadget-model validate-loc ] keep - editor-caret set-model + over set-caret mark>caret ; : handle-parse-error ( interactor error -- ) dup parse-error? [ 2dup go-to-error delegate ] when swap find-workspace debugger-popup ; -: try-parse ( str interactor -- quot/error/f ) +: try-parse ( lines interactor -- quot/error/f ) [ - [ - [ restore-vars parse ] keep save-vars - ] [ - >r f swap set-interactor-busy? drop r> - dup delegate unexpected-eof? [ drop f ] when - ] recover - ] with-scope ; + >r parse-lines-interactive r> save-use + ] [ + >r f swap set-interactor-busy? drop r> + dup delegate unexpected-eof? [ drop f ] when + ] recover ; -: handle-interactive ( str/f interactor -- ) +: handle-interactive ( lines interactor -- quot/f ? ) tuck try-parse { - { [ dup quotation? ] [ swap interactor-finish ] } - { [ dup not ] [ drop "\n" swap user-input ] } - { [ t ] [ handle-parse-error ] } + { [ dup quotation? ] [ nip t ] } + { [ dup not ] [ drop "\n" swap user-input f f ] } + { [ t ] [ handle-parse-error f f ] } } cond ; M: interactor stream-read-quot - [ save-vars ] keep - [ [ handle-interactive ] interactor-yield ] keep - restore-vars ; + [ save-use ] keep + [ interactor-yield ] keep over quotation? [ + drop + ] [ + [ handle-interactive ] keep swap + [ interactor-finish ] [ nip stream-read-quot ] if + ] if ; M: interactor pref-dim* 0 over line-height 4 * 2array swap delegate pref-dim* vmax ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 4b030844c0..88901b4664 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -96,8 +96,8 @@ M: listener-operation invoke-command ( target command -- ) get-listener [ word-completion-string ] keep listener-gadget-input user-input ; -: quot-action ( interactor -- quot ) - dup editor-string swap +: quot-action ( interactor -- lines ) + dup control-value swap 2dup add-interactor-history select-all ; diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 8ac7ec710a..6860b79ffc 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -196,5 +196,5 @@ interactor "These commands operate on the entire contents of the input area." [ ] [ quot-action ] -[ parse ] +[ [ parse-lines ] with-compilation-unit ] define-operation-map From 6922bded81c738384a54e13c8b9a91ad53fc6bd1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Dec 2007 21:34:44 -0500 Subject: [PATCH 64/82] Speed up compile-call --- core/compiler/compiler.factor | 4 +--- vm/code_heap.c | 23 ++++++++++++++++++++++- 2 files changed, 23 insertions(+), 4 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index a18b832725..5f3db69c81 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -55,9 +55,7 @@ IN: compiler [ compiled? not ] subset recompile ; : compile-call ( quot -- ) - H{ } clone changed-words [ - define-temp dup 1array recompile - ] with-variable execute ; + [ define-temp ] with-compilation-unit execute ; : recompile-all ( -- ) [ all-words recompile ] with-compiler-errors ; diff --git a/vm/code_heap.c b/vm/code_heap.c index 93f078cfda..3f75153baa 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -339,6 +339,8 @@ DEFINE_PRIMITIVE(modify_code_heap) { F_ARRAY *alist = untag_array(dpop()); + bool rescan_code_heap = false; + CELL count = untag_fixnum_fast(alist->capacity); CELL i; for(i = 0; i < count; i++) @@ -346,6 +348,10 @@ DEFINE_PRIMITIVE(modify_code_heap) F_ARRAY *pair = untag_array(array_nth(alist,i)); F_WORD *word = untag_word(array_nth(pair,0)); + + if(word->vocabulary != F) + rescan_code_heap = true; + CELL data = array_nth(pair,1); if(data == F) @@ -395,6 +401,21 @@ DEFINE_PRIMITIVE(modify_code_heap) } } - if(count != 0) + /* If there were any interned words in the set, we relocate all XT + references in the entire code heap. But if all the words are + uninterned, it is impossible that other words reference them, so we + only have to relocate the new words. This makes compile-call much + more efficient */ + if(rescan_code_heap) iterate_code_heap(relocate_code_block); + else + { + for(i = 0; i < count; i++) + { + F_ARRAY *pair = untag_array(array_nth(alist,i)); + F_WORD *word = untag_word(array_nth(pair,0)); + + iterate_code_heap_step(word->code,relocate_code_block); + } + } } From e3af94cfbddca2898f21f15f23c6d9d340aa12b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Dec 2007 23:16:21 -0400 Subject: [PATCH 65/82] Remove redundant tools.walker vocab --- extra/bootstrap/tools/tools.factor | 1 - extra/tools/interpreter/interpreter.factor | 14 +++++++------- extra/tools/walker/authors.txt | 1 - extra/tools/walker/summary.txt | 1 - extra/tools/walker/tags.txt | 1 - extra/tools/walker/walker.factor | 6 ------ extra/ui/tools/operations/operations.factor | 2 +- extra/ui/tools/tools-docs.factor | 2 +- 8 files changed, 9 insertions(+), 19 deletions(-) mode change 100644 => 100755 extra/tools/interpreter/interpreter.factor delete mode 100644 extra/tools/walker/authors.txt delete mode 100644 extra/tools/walker/summary.txt delete mode 100644 extra/tools/walker/tags.txt delete mode 100644 extra/tools/walker/walker.factor mode change 100644 => 100755 extra/ui/tools/tools-docs.factor diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index f94bf80bbf..fab6a093ee 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -9,6 +9,5 @@ USING: vocabs.loader sequences ; "tools.profiler" "tools.test" "tools.time" - "tools.walker" "editors" } [ require ] each diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor old mode 100644 new mode 100755 index a43a4b46ce..53de43b7e5 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -6,6 +6,8 @@ kernel.private math namespaces namespaces.private prettyprint quotations sequences splitting strings threads vectors words ; IN: tools.interpreter +: walk ( quot -- ) \ break add* call ; + TUPLE: interpreter continuation ; : interpreter construct-empty ; @@ -30,19 +32,17 @@ M: pair restore Date: Tue, 1 Jan 2008 15:54:14 -0400 Subject: [PATCH 66/82] Working on compiled-usage --- core/alien/compiler/compiler.factor | 2 +- core/bootstrap/compiler/compiler.factor | 9 +- core/compiler/compiler.factor | 77 ++++++++++----- core/compiler/test/redefine.factor | 96 ++++++++++++++++++- core/cpu/x86/assembler/assembler.factor | 2 +- core/generator/generator-docs.factor | 5 +- core/inference/backend/backend-docs.factor | 12 +-- core/inference/backend/backend.factor | 21 ++-- core/inference/dataflow/dataflow-docs.factor | 3 - core/inference/dataflow/dataflow.factor | 25 +---- core/inference/inference-docs.factor | 2 +- core/inference/inference.factor | 4 +- core/inference/known-words/known-words.factor | 18 ++-- core/inference/state/state-docs.factor | 11 +++ core/inference/state/state.factor | 45 +++++++++ core/inference/transforms/transforms.factor | 2 +- 16 files changed, 245 insertions(+), 89 deletions(-) mode change 100644 => 100755 core/inference/backend/backend-docs.factor mode change 100644 => 100755 core/inference/dataflow/dataflow-docs.factor mode change 100644 => 100755 core/inference/dataflow/dataflow.factor create mode 100755 core/inference/state/state-docs.factor create mode 100755 core/inference/state/state.factor mode change 100644 => 100755 core/inference/transforms/transforms.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 6ba63eeefc..85b66bc9e5 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words -inference.backend inference.dataflow system +inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators ; diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 03524ee040..09da7f6af4 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: compiler cpu.architecture vocabs.loader system sequences namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors tuples sbufs inference.dataflow @@ -59,6 +61,8 @@ nl hashcode* = get set } compile +"." write flush + { . lines } compile @@ -69,7 +73,6 @@ nl malloc free memcpy } compile -" done" print -nl +[ compiled-usages recompile ] recompile-hook set-global -[ recompile ] recompile-hook set-global +" done" print flush diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 5f3db69c81..5c5c4cf286 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -1,36 +1,63 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces arrays sequences io inference.backend -generator debugger math.parser prettyprint words words.private -continuations vocabs assocs alien.compiler dlists optimizer -definitions math compiler.errors threads ; +inference.state generator debugger math.parser prettyprint words +words.private continuations vocabs assocs alien.compiler dlists +optimizer definitions math compiler.errors threads graphs +generic ; IN: compiler -: compiled-usage ( word -- seq ) - #! XXX - usage [ word? ] subset ; +SYMBOL: compiled-crossref -: ripple-up ( word effect -- ) - over "compiled-effect" word-prop = - [ drop ] [ - compiled-usage - [ "was-compiled" word-prop ] subset - [ queue-compile ] each - ] if ; +compiled-crossref global [ H{ } assoc-like ] change-at + +: compiled-xref ( word dependencies -- ) + 2dup "compiled-uses" set-word-prop + compiled-crossref get add-vertex ; + +: compiled-unxref ( word -- ) + dup "compiled-uses" word-prop + compiled-crossref get remove-vertex ; + +: compiled-usage ( word -- seq ) + compiled-crossref get at keys ; + +: compiled-usages ( words -- seq ) + compiled-crossref get [ + [ + over dup set + over "inline" word-prop pick generic? or + [ at namespace swap update ] [ 2drop ] if + ] curry each + ] H{ } make-assoc keys ; + +: ripple-up ( word -- ) + compiled-usage [ queue-compile ] each ; : save-effect ( word effect -- ) - over t "was-compiled" set-word-prop + over "compiled-uses" word-prop [ + 2dup swap "compiled-effect" word-prop = + [ over ripple-up ] unless + ] when "compiled-effect" set-word-prop ; -: (compile) ( word -- ) +: finish-compile ( word effect dependencies -- ) + >r dupd save-effect r> over compiled-unxref compiled-xref ; + +: compile-succeeded ( word -- effect dependencies ) [ - dup word-dataflow optimize >r over dup r> generate - ] [ - dup inference-error? [ rethrow ] unless - over compiler-error f over compiled get set-at f - ] recover - 2drop ; -! 2dup ripple-up save-effect ; + dup word-dataflow >r swap dup r> optimize generate + ] computing-dependencies ; + +: compile-failed ( word error -- ) + dup inference-error? [ rethrow ] unless + f pick compiled get set-at + swap compiler-error ; + +: (compile) ( word -- ) + [ dup compile-succeeded finish-compile ] + [ dupd compile-failed f save-effect ] + recover ; : delete-any ( assoc -- element ) [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ; @@ -55,7 +82,9 @@ IN: compiler [ compiled? not ] subset recompile ; : compile-call ( quot -- ) - [ define-temp ] with-compilation-unit execute ; + H{ } clone changed-words + [ define-temp dup 1array compile ] with-variable + execute ; : recompile-all ( -- ) [ all-words recompile ] with-compiler-errors ; diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 21d1bfe87a..48504a5bac 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -1,8 +1,26 @@ USING: compiler definitions generic assocs inference math namespaces parser tools.test words kernel sequences arrays io -effects tools.test.inference ; +effects tools.test.inference words.private ; IN: temporary +DEFER: x-1 +DEFER: x-2 + +[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [ + "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval + "IN: temporary : x-2 3 x-1 ;" eval + + [ t ] [ + { x-2 } compile + + \ x-2 word-xt + + { x-1 } compile + + \ x-2 word-xt eq? + ] unit-test +] with-variable + DEFER: b DEFER: c @@ -49,3 +67,79 @@ DEFER: c [ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test [ 4 4 ] [ "USE: temporary e" eval ] unit-test + +DEFER: x-3 + +[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test + +DEFER: x-4 + +[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test + +[ t ] [ \ x-4 compiled? ] unit-test + +[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test + +[ f ] [ \ x-3 compiled? ] unit-test + +[ f ] [ \ x-4 compiled? ] unit-test + +[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test + +[ t ] [ \ x-3 compiled? ] unit-test + +[ t ] [ \ x-4 compiled? ] unit-test + +[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test + +[ t ] [ \ x-3 "compiled-uses" word-prop [ interned? ] all? ] unit-test + +DEFER: g-test-1 + +DEFER: g-test-3 + +[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test + +[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test + +[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test + +[ 25 ] [ 5 g-test-1 ] unit-test + +[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test + +[ 5 ] [ 5 g-test-1 ] unit-test + +[ t ] [ + \ g-test-3 word-xt + + "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval + + \ g-test-3 word-xt eq? +] unit-test + +DEFER: g-test-5 + +[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test + +[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test + +[ 6 ] [ g-test-5 ] unit-test + +[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test + +[ 13 ] [ g-test-5 ] unit-test + +DEFER: g-test-6 + +[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test + +DEFER: g-test-7 + +[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test + +[ 133 ] [ g-test-7 ] unit-test + +[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test + +[ 138 ] [ g-test-7 ] unit-test diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 15b0d57f4f..3163ce1b41 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator.fixup io.binary kernel combinators kernel.private math namespaces parser sequences diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 69262b0470..e5595f7817 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -1,5 +1,6 @@ USING: help.markup help.syntax words debugger generator.fixup -generator.registers quotations kernel vectors arrays effects ; +generator.registers quotations kernel vectors arrays effects +sequences ; IN: generator ARTICLE: "generator" "Compiled code generator" @@ -54,7 +55,7 @@ HELP: generate { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ; HELP: word-dataflow -{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } } +{ $values { "word" word } { "effect" effect } { "dependencies" sequence } { "dataflow" "a dataflow graph" } } { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ; HELP: define-intrinsics diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor old mode 100644 new mode 100755 index 05d80f6955..98e2e6bbcd --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -1,17 +1,11 @@ USING: help.syntax help.markup words effects inference.dataflow -inference.backend kernel sequences kernel.private -combinators combinators.private ; - -HELP: recursive-state -{ $var-description "During inference, holds an association list mapping words to labels." } ; +inference.state inference.backend kernel sequences +kernel.private combinators combinators.private ; HELP: literal-expected { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } { $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ; -HELP: terminated? -{ $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ; - HELP: too-many->r { $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." } { $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ; @@ -57,7 +51,7 @@ HELP: collect-recursion { $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } } { $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ; -HELP: inline-closure +HELP: inline-word { $values { "word" word } } { $description "Called during inference to infer stack effects of inline words." $nl diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 520b0ec485..862c86cce9 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: inference.dataflow inference.state arrays generic io +io.streams.string kernel math namespaces parser prettyprint +sequences strings vectors words quotations effects classes +continuations debugger assocs combinators compiler.errors ; IN: inference.backend -USING: inference.dataflow arrays generic io io.streams.string -kernel math namespaces parser prettyprint sequences -strings vectors words quotations effects classes continuations -debugger assocs combinators compiler.errors ; : recursive-label ( word -- label/f ) recursive-state get at ; @@ -57,14 +57,10 @@ M: object value-literal \ literal-expected inference-warning ; : ensure-values ( seq -- ) meta-d [ add-inputs ] change d-in [ + ] change ; -SYMBOL: terminated? - : current-effect ( -- effect ) d-in get meta-d get length terminated? get over set-effect-terminated? ; -SYMBOL: recorded - : init-inference ( -- ) terminated? off V{ } clone meta-d set @@ -340,6 +336,7 @@ TUPLE: unbalanced-branches-error quots in out ; recursive-label #call-label [ consume/produce ] keep set-node-in-d ] [ + dup depends-on over effect-in length reify-curries #call consume/produce ] if ; @@ -370,6 +367,7 @@ TUPLE: effect-error word effect ; : infer-compound ( word -- effect ) [ init-inference + dependencies off dup word-def over dup infer-quot-recursive finish-word current-effect @@ -446,7 +444,8 @@ M: #call-label collect-recursion* [ swap [ at ] curry map ] keep [ set ] 2each ; -: inline-closure ( word -- ) +: inline-word ( word -- ) + dup depends-on dup inline-block over recursive-label? [ flatten-meta-d >r drop join-values inline-block apply-infer @@ -462,7 +461,7 @@ M: #call-label collect-recursion* M: compound apply-object [ dup inline-recursive-label - [ declared-infer ] [ inline-closure ] if + [ declared-infer ] [ inline-word ] if ] [ dup recursive-label [ declared-infer ] [ apply-word ] if diff --git a/core/inference/dataflow/dataflow-docs.factor b/core/inference/dataflow/dataflow-docs.factor old mode 100644 new mode 100755 index 2777d479c3..0f809fa2bd --- a/core/inference/dataflow/dataflow-docs.factor +++ b/core/inference/dataflow/dataflow-docs.factor @@ -3,6 +3,3 @@ USING: inference.dataflow help.syntax help.markup ; HELP: #return { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } } { $description "Creates a node which returns from a nested label, or if " { $snippet "label" } " is " { $link f } ", the top-level word being compiled." } ; - -HELP: d-in -{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor old mode 100644 new mode 100755 index c9531f8043..9689a1455d --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -1,11 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic assocs kernel math namespaces parser +sequences words vectors math.intervals effects classes +inference.state ; IN: inference.dataflow -USING: arrays generic assocs kernel math -namespaces parser sequences words vectors math.intervals -effects classes ; - -SYMBOL: recursive-state ! Computed value : \ counter ; @@ -30,20 +28,8 @@ TUPLE: composed quot1 quot2 ; C: composed -SYMBOL: d-in -SYMBOL: meta-d -SYMBOL: meta-r - UNION: special curried composed ; -: push-d meta-d get push ; -: pop-d meta-d get pop ; -: peek-d meta-d get peek ; - -: push-r meta-r get push ; -: pop-r meta-r get pop ; -: peek-r meta-r get peek ; - TUPLE: node param in-d out-d in-r out-r classes literals intervals @@ -185,9 +171,6 @@ UNION: #branch #if #dispatch ; >r r-tail flatten-curries r> set-node-out-r >r d-tail flatten-curries r> set-node-out-d ; -SYMBOL: dataflow-graph -SYMBOL: current-node - : node, ( node -- ) dataflow-graph get [ dup current-node [ set-node-successor ] change diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5a9c306abf..508b0a6510 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -1,6 +1,6 @@ USING: help.syntax help.markup kernel sequences words io effects inference.dataflow inference.backend -math combinators inference.transforms ; +math combinators inference.transforms inference.state ; IN: inference ARTICLE: "inference-simple" "Straight-line stack effects" diff --git a/core/inference/inference.factor b/core/inference/inference.factor index 9588976e50..0fc344dd85 100755 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: inference -USING: inference.backend inference.dataflow +USING: inference.backend inference.state inference.dataflow inference.known-words inference.transforms inference.errors sequences prettyprint io effects kernel namespaces quotations words vocabs ; +IN: inference GENERIC: infer ( quot -- effect ) diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 46b1aa8712..d0d23fe3db 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: inference.known-words USING: alien arrays bit-arrays byte-arrays classes combinators.private continuations.private effects float-arrays -generic hashtables hashtables.private inference.backend -inference.dataflow io io.backend io.files io.files.private -io.streams.c kernel kernel.private math math.private memory -namespaces namespaces.private parser prettyprint quotations -quotations.private sbufs sbufs.private sequences -sequences.private slots.private strings strings.private system -threads.private tuples tuples.private vectors vectors.private -words words.private assocs ; +generic hashtables hashtables.private inference.state +inference.backend inference.dataflow io io.backend io.files +io.files.private io.streams.c kernel kernel.private math +math.private memory namespaces namespaces.private parser +prettyprint quotations quotations.private sbufs sbufs.private +sequences sequences.private slots.private strings +strings.private system threads.private tuples tuples.private +vectors vectors.private words words.private assocs ; +IN: inference.known-words ! Shuffle words : infer-shuffle-inputs ( shuffle node -- ) diff --git a/core/inference/state/state-docs.factor b/core/inference/state/state-docs.factor new file mode 100755 index 0000000000..8c233e9616 --- /dev/null +++ b/core/inference/state/state-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax inference.state ; + +HELP: d-in +{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ; + +HELP: recursive-state +{ $var-description "During inference, holds an association list mapping words to labels." } ; + +HELP: terminated? +{ $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ; + diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor new file mode 100755 index 0000000000..f1b2bff316 --- /dev/null +++ b/core/inference/state/state.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs namespaces sequences kernel ; +IN: inference.state + +! Nesting state to solve recursion +SYMBOL: recursive-state + +! Number of inputs current word expects from the stack +SYMBOL: d-in + +! Compile-time data stack +SYMBOL: meta-d + +: push-d meta-d get push ; +: pop-d meta-d get pop ; +: peek-d meta-d get peek ; + +! Compile-time retain stack +SYMBOL: meta-r + +: push-r meta-r get push ; +: pop-r meta-r get pop ; +: peek-r meta-r get peek ; + +! Head of dataflow IR +SYMBOL: dataflow-graph + +SYMBOL: current-node + +! Words that the current dataflow IR depends on +SYMBOL: dependencies + +: depends-on ( word -- ) + dup dependencies get dup [ set-at ] [ 3drop ] if ; + +: computing-dependencies ( quot -- dependencies ) + H{ } clone [ dependencies rot with-variable ] keep keys ; + inline + +! Did the current control-flow path throw an error? +SYMBOL: terminated? + +! Words we've inferred the stack effect of, for rollback +SYMBOL: recorded diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor old mode 100644 new mode 100755 index b52357fc81..e36d703be8 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel words sequences generic math namespaces quotations assocs combinators math.bitfields inference.backend -inference.dataflow tuples.private ; +inference.dataflow inference.state tuples.private ; IN: inference.transforms : pop-literals ( n -- rstate seq ) From b7327b62280b0f0a938f8d2c6c33097acd160601 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Jan 2008 20:36:36 -0400 Subject: [PATCH 67/82] Redo the profiler --- core/alien/c-types/c-types.factor | 4 +- core/alien/compiler/compiler.factor | 1 - core/alien/syntax/syntax-docs.factor | 2 +- core/alien/syntax/syntax.factor | 2 +- core/bootstrap/compiler/compiler.factor | 1 - core/bootstrap/image/image.factor | 25 ++-- core/bootstrap/primitives.factor | 6 +- core/classes/classes-docs.factor | 2 +- core/classes/classes-tests.factor | 4 +- core/classes/classes.factor | 3 +- core/compiler/constants/constants.factor | 22 ++++ core/cpu/architecture/architecture.factor | 13 +-- core/cpu/arm/allot/allot.factor | 2 +- core/cpu/arm/architecture/architecture.factor | 2 +- core/cpu/ppc/allot/allot.factor | 2 +- core/cpu/ppc/architecture/architecture.factor | 2 +- core/cpu/x86/32/32.factor | 2 - core/cpu/x86/allot/allot.factor | 2 +- core/cpu/x86/architecture/architecture.factor | 21 +--- core/cpu/x86/bootstrap.factor | 29 +++-- core/cpu/x86/intrinsics/intrinsics.factor | 8 +- core/generator/fixup/fixup.factor | 7 +- core/generator/generator.factor | 50 ++------ core/generic/generic.factor | 7 +- core/inference/backend/backend.factor | 28 ++--- core/inference/class/class-tests.factor | 3 +- core/inference/inference-tests.factor | 7 +- core/inference/known-words/known-words.factor | 4 +- core/kernel/kernel.factor | 2 + core/layouts/layouts-docs.factor | 6 +- core/layouts/layouts.factor | 2 +- core/prettyprint/prettyprint-tests.factor | 8 +- .../prettyprint/sections/sections-docs.factor | 2 +- core/slots/slots.factor | 6 +- core/syntax/syntax-docs.factor | 4 +- core/syntax/syntax.factor | 5 +- core/vocabs/loader/loader-tests.factor | 4 +- core/words/words-docs.factor | 63 +++++----- core/words/words-tests.factor | 18 +-- core/words/words.factor | 32 ++--- extra/help/handbook/handbook.factor | 5 +- extra/macros/macros.factor | 5 +- extra/tools/annotations/annotations.factor | 14 +-- extra/tools/interpreter/interpreter.factor | 6 +- extra/ui/tools/operations/operations.factor | 2 +- vm/code_gc.c | 9 +- vm/code_heap.c | 109 ++++++++---------- vm/code_heap.h | 5 +- vm/data_gc.c | 30 ++--- vm/factor.c | 19 ++- vm/image.c | 24 +--- vm/layouts.h | 5 +- vm/profiler.c | 62 ++++++++-- vm/profiler.h | 4 +- vm/quotations.c | 77 +++++++------ vm/run.c | 16 --- vm/run.h | 9 +- vm/types.c | 28 ++++- vm/types.h | 6 +- 59 files changed, 388 insertions(+), 460 deletions(-) mode change 100644 => 100755 core/classes/classes-docs.factor create mode 100755 core/compiler/constants/constants.factor mode change 100644 => 100755 core/generator/fixup/fixup.factor mode change 100644 => 100755 core/layouts/layouts-docs.factor mode change 100644 => 100755 core/layouts/layouts.factor mode change 100644 => 100755 core/prettyprint/sections/sections-docs.factor mode change 100644 => 100755 core/slots/slots.factor mode change 100644 => 100755 vm/profiler.h diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f35981ce77..91a2e6efaa 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -194,7 +194,7 @@ M: long-long-type box-return ( type -- ) >r ">c-" swap "-array" 3append r> create ; : define-to-array ( type vocab -- ) - [ to-array-word ] 2keep >c-array-quot define-compound ; + [ to-array-word ] 2keep >c-array-quot define ; : c-array>quot ( type vocab -- quot ) [ @@ -207,7 +207,7 @@ M: long-long-type box-return ( type -- ) >r "c-" swap "-array>" 3append r> create ; : define-from-array ( type vocab -- ) - [ from-array-word ] 2keep c-array>quot define-compound ; + [ from-array-word ] 2keep c-array>quot define ; : ( getter setter width boxer unboxer -- type ) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 85b66bc9e5..51240a66d9 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -394,7 +394,6 @@ TUPLE: callback-context ; dup wrap-callback-quot %alien-callback %callback-return ] with-stack-frame - 0 ] generate-1 ; M: alien-callback generate-node diff --git a/core/alien/syntax/syntax-docs.factor b/core/alien/syntax/syntax-docs.factor index 82f1ea3b78..d87b67eb59 100755 --- a/core/alien/syntax/syntax-docs.factor +++ b/core/alien/syntax/syntax-docs.factor @@ -69,7 +69,7 @@ HELP: C-UNION: HELP: C-ENUM: { $syntax "C-ENUM: words... ;" } { $values { "words" "a sequence of word names" } } -{ $description "Creates a sequence of compound definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." } +{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." } { $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." } { $examples "The following two lines are equivalent:" diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 12bf0c5cb9..99275d02bf 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -49,7 +49,7 @@ PRIVATE> : C-ENUM: ";" parse-tokens dup length - [ >r create-in r> 1quotation define-compound ] 2each ; + [ >r create-in r> 1quotation define ] 2each ; parsing M: alien pprint* diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 09da7f6af4..902c406158 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -12,7 +12,6 @@ IN: bootstrap.compiler "-no-stack-traces" cli-args member? [ f compiled-stack-traces? set-global - 0 profiler-prologue set-global ] when nl diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 0052dd34f2..84e0f6ed1e 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays bit-arrays byte-arrays generic assocs hashtables assocs hashtables.private io kernel kernel.private @@ -62,8 +62,8 @@ SYMBOL: bootstrap-boot-quot ! JIT parameters SYMBOL: jit-code-format SYMBOL: jit-prolog -SYMBOL: jit-word-primitive-jump -SYMBOL: jit-word-primitive-call +SYMBOL: jit-primitive-word +SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-literal @@ -73,6 +73,7 @@ SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return +SYMBOL: jit-profiling ! Default definition for undefined words SYMBOL: undefined-quot @@ -83,8 +84,8 @@ SYMBOL: undefined-quot { bootstrap-global 21 } { jit-code-format 22 } { jit-prolog 23 } - { jit-word-primitive-jump 24 } - { jit-word-primitive-call 25 } + { jit-primitive-word 24 } + { jit-primitive 25 } { jit-word-jump 26 } { jit-word-call 27 } { jit-push-literal 28 } @@ -94,6 +95,7 @@ SYMBOL: undefined-quot { jit-dispatch 32 } { jit-epilog 33 } { jit-return 34 } + { jit-profiling 35 } { undefined-quot 37 } } at header-size + ; @@ -121,10 +123,10 @@ SYMBOL: undefined-quot : align-here ( -- ) here 8 mod 4 = [ 0 emit ] when ; -: emit-fixnum ( n -- ) tag-bits get shift emit ; +: emit-fixnum ( n -- ) tag-fixnum emit ; : emit-object ( header tag quot -- addr ) - swap here-as >r swap tag-header emit call align-here r> ; + swap here-as >r swap tag-fixnum emit call align-here r> ; inline ! Write an object to the image. @@ -174,7 +176,7 @@ M: fixnum ' #! When generating a 32-bit image on a 64-bit system, #! some fixnums should be bignums. dup most-negative-fixnum most-positive-fixnum between? - [ tag-bits get shift ] [ >bignum ' ] if ; + [ tag-fixnum ] [ >bignum ' ] if ; ! Floats @@ -214,6 +216,7 @@ M: f ' 0 , ! count 0 , ! xt 0 , ! code + 0 , ! profiling ] { } make \ word type-number object tag-number [ emit-seq ] emit-object @@ -368,12 +371,13 @@ M: curry ' : emit-jit-data ( -- ) \ if jit-if-word set \ dispatch jit-dispatch-word set + \ do-primitive jit-primitive-word set [ undefined ] undefined-quot set { jit-code-format jit-prolog - jit-word-primitive-jump - jit-word-primitive-call + jit-primitive-word + jit-primitive jit-word-jump jit-word-call jit-push-literal @@ -383,6 +387,7 @@ M: curry ' jit-dispatch jit-epilog jit-return + jit-profiling undefined-quot } [ emit-userenv ] each ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 702cc3e47d..586d4c0dfa 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -314,7 +314,7 @@ define-builtin { "set-word-vocabulary" "words" } } { - { "object" "kernel" } + { "quotation" "quotations" } "def" 4 { "word-def" "words" } @@ -408,7 +408,7 @@ builtins get num-tags get tail f union-class define-class ! Primitive words : make-primitive ( word vocab n -- ) - >r create dup reset-word r> define ; + >r create dup reset-word r> [ do-primitive ] curry [ ] like define ; { { "(execute)" "words.private" } @@ -607,4 +607,4 @@ builtins get num-tags get tail f union-class define-class dup length [ >r first2 r> make-primitive ] 2each ! Bump build number -"build" "kernel" create build 1+ 1quotation define-compound +"build" "kernel" create build 1+ 1quotation define diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor old mode 100644 new mode 100755 index 130844e797..6cc08e9f8f --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -122,7 +122,7 @@ HELP: predicate-word HELP: define-predicate { $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } } { $description - "Defines a predicate word. This is identical to a compound definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:" + "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:" { $list { "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" } { "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 00bf3262aa..592691f6c7 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -36,8 +36,8 @@ UNION: both first-one union-class ; [ f ] [ \ integer \ null class< ] unit-test [ t ] [ \ null \ object class< ] unit-test -[ t ] [ \ generic \ compound class< ] unit-test -[ f ] [ \ compound \ generic class< ] unit-test +[ t ] [ \ generic \ word class< ] unit-test +[ f ] [ \ word \ generic class< ] unit-test [ f ] [ \ reversed \ slice class< ] unit-test [ f ] [ \ slice \ reversed class< ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ee5dd2c7e9..ac40bc3a1a 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -27,8 +27,7 @@ PREDICATE: class tuple-class : predicate-effect 1 { "?" } ; -PREDICATE: compound predicate - "predicating" word-prop >boolean ; +PREDICATE: word predicate "predicating" word-prop >boolean ; : define-predicate ( class predicate quot -- ) over [ diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor new file mode 100755 index 0000000000..3de32ab7fa --- /dev/null +++ b/core/compiler/constants/constants.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math kernel layouts system ; +IN: compiler.constants + +! These constants must match vm/memory.h +: card-bits 6 ; +: card-mark HEX: 40 HEX: 80 bitor ; + +! These constants must match vm/layouts.h +: header-offset object tag-number neg ; +: float-offset 8 float tag-number - ; +: string-offset 3 bootstrap-cells object tag-number - ; +: profile-count-offset 7 bootstrap-cells object tag-number - ; +: byte-array-offset 2 bootstrap-cells object tag-number - ; +: alien-offset 3 bootstrap-cells object tag-number - ; +: underlying-alien-offset bootstrap-cell object tag-number - ; +: tuple-class-offset 2 bootstrap-cells tuple tag-number - ; +: class-hash-offset bootstrap-cell object tag-number - ; +: word-xt-offset 8 bootstrap-cells object tag-number - ; +: word-code-offset 9 bootstrap-cells object tag-number - ; +: compiled-header-size 8 bootstrap-cells ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 538f17d2e0..3550dcadc0 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien byte-arrays bit-arrays float-arrays combinators words ; IN: cpu.architecture -SYMBOL: profiler-prologue - SYMBOL: compiler-backend ! A pseudo-register class for parameters spilled on the stack @@ -45,9 +43,6 @@ HOOK: %epilogue compiler-backend ( n -- ) : %epilogue-later \ %epilogue-later , ; -! Bump profiling counter -HOOK: %profiler-prologue compiler-backend ( word -- ) - ! Store word XT in stack frame HOOK: %save-word-xt compiler-backend ( -- ) @@ -59,15 +54,9 @@ M: object %save-dispatch-xt %save-word-xt ; ! Call another label HOOK: %call-label compiler-backend ( label -- ) -! Call C primitive -HOOK: %call-primitive compiler-backend ( label -- ) - ! Local jump for branches HOOK: %jump-label compiler-backend ( label -- ) -! Far jump to C primitive -HOOK: %jump-primitive compiler-backend ( label -- ) - ! Test if vreg is 'f' or not HOOK: %jump-t compiler-backend ( label -- ) @@ -159,7 +148,7 @@ M: stack-params param-reg drop ; GENERIC: v>operand ( obj -- operand ) -M: integer v>operand tag-bits get shift ; +M: integer v>operand tag-fixnum ; M: f v>operand drop \ f tag-number ; diff --git a/core/cpu/arm/allot/allot.factor b/core/cpu/arm/allot/allot.factor index 41a5cab91e..27a4676926 100755 --- a/core/cpu/arm/allot/allot.factor +++ b/core/cpu/arm/allot/allot.factor @@ -17,7 +17,7 @@ IN: cpu.arm.allot R11 R11 pick ADD ! increment r11 R11 R12 cell <+> STR ! r11 -> nursery.here R11 R11 rot SUB ! old value - R12 swap type-number tag-header MOV ! compute header + R12 swap type-number tag-fixnum MOV ! compute header R12 R11 0 <+> STR ! store header ; diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 4e693bbe34..8742a693cb 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -350,7 +350,7 @@ M: arm-backend %unbox-any-c-ptr ( dst src -- ) "end" get EQ B ! Is the object an alien? R14 R12 header-offset <+/-> LDR - R14 alien type-number tag-header CMP + R14 alien type-number tag-fixnum CMP ! Add byte array address to address being computed R11 R11 R12 NE ADD ! Add an offset to start of byte array's data area diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index a8c26d36bf..df0a08a86d 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -18,7 +18,7 @@ IN: cpu.ppc.allot 11 11 pick ADDI ! increment r11 11 12 cell STW ! r11 -> nursery.here 11 11 rot SUBI ! old value - type-number tag-header 12 LI ! compute header + type-number tag-fixnum 12 LI ! compute header 12 11 0 STW ! store header ; diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 43a2428d42..8bd9ca505d 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -333,7 +333,7 @@ M: ppc-backend %unbox-any-c-ptr ( dst src -- ) "end" get BEQ ! Is the object an alien? 0 11 header-offset LWZ - 0 0 alien type-number tag-header CMPI + 0 0 alien type-number tag-fixnum CMPI "is-byte-array" get BNE ! If so, load the offset 0 11 alien-offset LWZ diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index ddc72a0453..1104915a9e 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -275,8 +275,6 @@ T{ x86-backend f 4 } compiler-backend set-global JNE ] { } define-if-intrinsic -10 profiler-prologue set-global - "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush [ sse2? ] compile-call [ diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index f32bda7d2c..f837a92504 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -30,7 +30,7 @@ IN: cpu.x86.allot allot-reg cell [+] swap 8 align ADD ; : store-header ( header -- ) - 0 object@ swap type-number tag-header MOV ; + 0 object@ swap type-number tag-fixnum MOV ; : %allot ( header size quot -- ) allot-reg PUSH diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index d059afe9f2..5195981657 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.compiler arrays cpu.x86.assembler cpu.architecture kernel kernel.private math memory namespaces sequences words generator generator.registers -generator.fixup system layouts combinators ; +generator.fixup system layouts combinators compiler.constants ; IN: cpu.x86.architecture TUPLE: x86-backend cell ; @@ -70,27 +70,10 @@ M: x86-backend %prepare-alien-invoke temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 3 cells [+] rs-reg MOV ; -M: x86-backend %profiler-prologue ( word -- ) - temp-reg load-literal - temp-reg v>operand profile-count-offset [+] 1 v>operand ADD ; - M: x86-backend %call-label ( label -- ) CALL ; M: x86-backend %jump-label ( label -- ) JMP ; -: %prepare-primitive ( word -- operand ) - ! Save stack pointer to stack_chain->callstack_top, load XT - ! in register - stack-save-reg stack-reg MOV address-operand ; - -M: x86-backend %call-primitive ( word -- ) - stack-save-reg stack-reg cell neg [+] LEA - address-operand CALL ; - -M: x86-backend %jump-primitive ( word -- ) - stack-save-reg stack-reg MOV - address-operand JMP ; - M: x86-backend %jump-t ( label -- ) "flag" operand f v>operand CMP JNE ; @@ -195,7 +178,7 @@ M: x86-backend %unbox-any-c-ptr ( dst src -- ) rs-reg f v>operand CMP "end" get JE ! Is the object an alien? - rs-reg header-offset [+] alien type-number tag-header CMP + rs-reg header-offset [+] alien type-number tag-fixnum CMP "is-byte-array" get JNE ! If so, load the offset and add it to the address ds-reg rs-reg alien-offset [+] ADD diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index be5275811c..af54b4dd7c 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs math generator.fixup ; +cpu.x86.assembler layouts vocabs math generator.fixup +compiler.constants ; IN: bootstrap.x86 big-endian off @@ -11,12 +12,23 @@ big-endian off : stack-frame-size 4 bootstrap-cells ; [ - arg0 0 [] MOV ! load quotation - arg1 arg0 quot-xt@ [+] MOV ! load XT + ! Load word + arg0 0 [] MOV + ! Bump profiling counter + arg0 profile-count-offset [+] 1 tag-fixnum ADD + ! Load word->code + arg0 arg0 word-code-offset [+] MOV + ! Compute word XT + arg0 compiled-header-size ADD + ! Jump to XT + arg0 JMP +] rc-absolute-cell rt-literal 2 jit-profiling jit-define + +[ stack-frame-size PUSH ! save stack frame size - arg1 PUSH ! save XT + 0 PUSH ! push XT arg1 PUSH ! alignment -] rc-absolute-cell rt-literal 2 jit-prolog jit-define +] rc-absolute-cell rt-xt 6 jit-prolog jit-define [ arg0 0 [] MOV ! load literal @@ -27,12 +39,7 @@ big-endian off [ arg1 stack-reg MOV ! pass callstack pointer as arg 2 (JMP) drop ! go -] rc-relative rt-primitive 3 jit-word-primitive-jump jit-define - -[ - arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2 - (CALL) drop ! go -] rc-relative rt-primitive 5 jit-word-primitive-call jit-define +] rc-relative rt-primitive 3 jit-primitive jit-define [ (JMP) drop diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index d1a851b553..9f6fb5d3b0 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -6,7 +6,7 @@ math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private sbufs sbufs.private vectors vectors.private layouts system -tuples.private strings.private slots.private ; +tuples.private strings.private slots.private compiler.constants ; IN: cpu.x86.intrinsics ! Type checks @@ -27,7 +27,7 @@ IN: cpu.x86.intrinsics ! Tag the tag "x" operand %tag-fixnum ! Compare with object tag number (3). - "x" operand object tag-number tag-bits get shift CMP + "x" operand object tag-number tag-fixnum CMP "end" get JNE ! If we have equality, load type from header "x" operand "obj" operand -3 [+] MOV @@ -49,10 +49,10 @@ IN: cpu.x86.intrinsics ! Tag the tag "x" operand %tag-fixnum ! Compare with tuple tag number (2). - "x" operand tuple tag-number tag-bits get shift CMP + "x" operand tuple tag-number tag-fixnum CMP "tuple" get JE ! Compare with object tag number (3). - "x" operand object tag-number tag-bits get shift CMP + "x" operand object tag-number tag-fixnum CMP "object" get JE "end" get JMP "object" get resolve-label diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor old mode 100644 new mode 100755 index 8730258d6d..393d0749ad --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -127,12 +127,7 @@ SYMBOL: word-table : rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ; -GENERIC# rel-word 1 ( word class -- ) - -M: primitive rel-word ( word class -- ) - >r word-def r> rt-primitive rel-fixup ; - -M: word rel-word ( word class -- ) +: rel-word ( word class -- ) >r add-word r> rt-xt rel-fixup ; : rel-literal ( literal class -- ) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index e085087da0..a33b0650ef 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -10,13 +10,13 @@ IN: generator SYMBOL: compile-queue SYMBOL: compiled -: 6array 3array >r 3array r> append ; +: 5array 3array >r 2array r> append ; : begin-compiling ( word -- ) f swap compiled get set-at ; -: finish-compiling ( word literals words relocation labels code profiler-prologue -- ) - 6array swap compiled get set-at ; +: finish-compiling ( word literals words relocation labels code -- ) + 5array swap compiled get set-at ; : queue-compile ( word -- ) { @@ -56,11 +56,6 @@ t compiled-stack-traces? set-global word-table get >array ] { } make fixup finish-compiling ; -: generate-profiler-prologue ( -- ) - compiled-stack-traces? get [ - compiling-word get %profiler-prologue - ] when ; - GENERIC: generate-node ( node -- next ) : generate-nodes ( node -- ) @@ -69,13 +64,11 @@ GENERIC: generate-node ( node -- next ) : generate ( word label node -- ) [ init-templates - generate-profiler-prologue %save-word-xt %prologue-later current-label-start define-label current-label-start resolve-label [ generate-nodes ] with-node-iterator - profiler-prologue get ] generate-1 ; : word-dataflow ( word -- effect dataflow ) @@ -113,21 +106,14 @@ UNION: #terminal ! node M: node generate-node drop iterate-next ; -: %call ( word -- ) - dup primitive? [ %call-primitive ] [ %call-label ] if ; +: %call ( word -- ) %call-label ; : %jump ( word -- ) - { - { [ dup compiling-label get eq? ] [ - drop current-label-start get %jump-label - ] } - { [ dup primitive? ] [ - %epilogue-later %jump-primitive - ] } - { [ t ] [ - %epilogue-later %jump-label - ] } - } cond ; + dup compiling-label get eq? [ + drop current-label-start get %jump-label + ] [ + %epilogue-later %jump-label + ] if ; : generate-call ( label -- next ) dup maybe-compile @@ -179,7 +165,6 @@ M: #if generate-node %save-dispatch-xt %prologue-later [ generate-nodes ] with-node-iterator - 0 ] generate-1 ] keep ; @@ -286,20 +271,3 @@ M: #r> generate-node ! #return M: #return generate-node drop end-basic-block %return f ; - -! These constants must match vm/memory.h -: card-bits 6 ; -: card-mark HEX: 40 HEX: 80 bitor ; - -! These constants must match vm/layouts.h -: header-offset object tag-number neg ; -: float-offset 8 float tag-number - ; -: string-offset 3 cells object tag-number - ; -: profile-count-offset 7 cells object tag-number - ; -: byte-array-offset 2 cells object tag-number - ; -: alien-offset 3 cells object tag-number - ; -: underlying-alien-offset cell object tag-number - ; -: tuple-class-offset 2 cells tuple tag-number - ; -: class-hash-offset cell object tag-number - ; -: word-xt-offset 8 cells object tag-number - ; -: compiled-header-size 8 cells ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index ed84c0fbd9..d57c4500e2 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -5,8 +5,7 @@ definitions kernel.private classes classes.private quotations arrays vocabs ; IN: generic -PREDICATE: compound generic ( word -- ? ) - "combination" word-prop >boolean ; +PREDICATE: word generic "combination" word-prop >boolean ; M: generic definer drop f f ; @@ -24,9 +23,7 @@ M: object perform-combination nip [ "Invalid method combination" throw ] curry [ ] like ; : make-generic ( word -- ) - dup - dup "combination" word-prop perform-combination - define-compound ; + dup dup "combination" word-prop perform-combination define ; : init-methods ( word -- ) dup "methods" word-prop diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 862c86cce9..5003336164 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -345,10 +345,6 @@ TUPLE: no-effect word ; : no-effect ( word -- * ) \ no-effect inference-warning ; -GENERIC: infer-word ( word -- effect ) - -M: word infer-word no-effect ; - TUPLE: effect-error word effect ; : effect-error ( word effect -- * ) @@ -364,18 +360,16 @@ TUPLE: effect-error word effect ; over recorded get push "inferred-effect" set-word-prop ; -: infer-compound ( word -- effect ) +: infer-word ( word -- effect ) [ - init-inference - dependencies off - dup word-def over dup infer-quot-recursive - finish-word - current-effect - ] with-scope ; - -M: compound infer-word - [ infer-compound ] [ ] [ t "no-effect" set-word-prop ] - cleanup ; + [ + init-inference + dependencies off + dup word-def over dup infer-quot-recursive + finish-word + current-effect + ] with-scope + ] [ ] [ t "no-effect" set-word-prop ] cleanup ; : custom-infer ( word -- ) #! Customized inference behavior @@ -392,8 +386,6 @@ M: compound infer-word { [ t ] [ dup infer-word make-call-node ] } } cond ; -M: word apply-object apply-word ; - TUPLE: recursive-declare-error word ; : declared-infer ( word -- ) @@ -458,7 +450,7 @@ M: #call-label collect-recursion* apply-infer node-child node-successor splice-node drop ] if ; -M: compound apply-object +M: word apply-object [ dup inline-recursive-label [ declared-infer ] [ inline-word ] if diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index c7289b110a..41f48e5521 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -141,8 +141,7 @@ DEFER: blah [ t ] [ [ \ blah - [ dup V{ } eq? [ foo ] when ] dup second dup push - define-compound + [ dup V{ } eq? [ foo ] when ] dup second dup push define ] with-compilation-unit \ blah compiled? diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 9ee2953445..f5ad256ec5 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -3,10 +3,9 @@ inference.dataflow kernel classes kernel.private math math.parser math.private namespaces namespaces.private parser sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions -prettyprint io inspector tuples -classes.union classes.predicate debugger bootstrap.image -bootstrap.image.private threads.private -io.streams.string combinators.private tools.test.inference ; +prettyprint io inspector tuples classes.union classes.predicate +debugger threads.private io.streams.string combinators.private +tools.test.inference ; IN: temporary { 0 2 } [ 2 "Hello" ] unit-test-effect diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index d0d23fe3db..747eeed673 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -9,7 +9,7 @@ math.private memory namespaces namespaces.private parser prettyprint quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private tuples tuples.private -vectors vectors.private words words.private assocs ; +vectors vectors.private words words.private assocs inspector ; IN: inference.known-words ! Shuffle words @@ -577,3 +577,5 @@ t over set-effect-terminated? \ set-innermost-frame-quot { quotation callstack } { } "inferred-effect" set-word-prop \ (os-envs) { } { array } "inferred-effect" set-word-prop + +\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 625c31eba1..2a0f46b72c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -159,4 +159,6 @@ GENERIC: construct-boa ( ... class -- tuple ) : declare ( spec -- ) drop ; +: do-primitive ( number -- ) "Improper primitive call" throw ; + PRIVATE> diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor old mode 100644 new mode 100755 index dccd13780f..0ce4c9bb73 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -23,9 +23,9 @@ HELP: type-number { $description "Outputs the built-in type number instances of " { $link class } ". Will output " { $link f } " if this is not a built-in class." } { $see-also builtin-class } ; -HELP: tag-header -{ $values { "n" "a built-in type number" } { "tagged" integer } } -{ $description "Outputs the header for objects of type " { $snippet "n" } "." } ; +HELP: tag-fixnum +{ $values { "n" integer } { "tagged" integer } } +{ $description "Outputs a tagged fixnum." } ; HELP: first-bignum { $values { "n" "smallest positive integer not representable by a fixnum" } } ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor old mode 100644 new mode 100755 index 31e182eac9..2f8b158bbf --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -21,7 +21,7 @@ SYMBOL: type-numbers : type-number ( class -- n ) type-numbers get at ; -: tag-header ( n -- tagged ) +: tag-fixnum ( n -- tagged ) tag-bits get shift ; : first-bignum ( -- n ) diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 700c7ea33c..0d7b19c837 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -2,7 +2,7 @@ USING: arrays definitions io.streams.string io.streams.duplex kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private -continuations ; +continuations generic ; IN: temporary [ "4" ] [ 4 unparse ] unit-test @@ -59,7 +59,7 @@ unit-test [ ] [ \ general-t see ] unit-test -[ ] [ \ compound see ] unit-test +[ ] [ \ generic see ] unit-test [ ] [ \ duplex-stream see ] unit-test @@ -150,8 +150,8 @@ unit-test "IN: temporary" ": retain-stack-layout" " dup stream-readln stream-readln" - " >r [ define-compound ] map r>" - " define-compound ;" + " >r [ define ] map r>" + " define ;" } ; [ t ] [ diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor old mode 100644 new mode 100755 index ad47dc0664..9833a7e50a --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -211,7 +211,7 @@ HELP: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -PREDICATE: compound slot-reader - "reading" word-prop >boolean ; +PREDICATE: word slot-reader "reading" word-prop >boolean ; : set-reader-props ( class spec -- ) 2dup reader-effect @@ -48,8 +47,7 @@ PREDICATE: compound slot-reader : writer-effect ( class spec -- effect ) slot-spec-name swap ?word-name 2array 0 ; -PREDICATE: compound slot-writer - "writing" word-prop >boolean ; +PREDICATE: word slot-writer "writing" word-prop >boolean ; : set-writer-props ( class spec -- ) 2dup writer-effect diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 9f6509989b..9cf9647e41 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -318,10 +318,10 @@ HELP: POSTPONE: HELP: : { $syntax ": word definition... ;" } { $values { "word" "a new word to define" } { "definition" "a word definition" } } -{ $description "Defines a compound word in the current vocabulary." } +{ $description "Defines a word in the current vocabulary." } { $examples { $code ": ask-name ( -- name )\n \"What is your name? \" write readln ;\n: greet ( name -- )\n \"Greetings, \" write print ;\n: friend ( -- )\n ask-name greet ;" } } ; -{ POSTPONE: : POSTPONE: ; define-compound } related-words +{ POSTPONE: : POSTPONE: ; define } related-words HELP: ; { $syntax ";" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 552c7480a3..85abd228cb 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -19,8 +19,7 @@ IN: bootstrap.syntax "syntax" lookup t "delimiter" set-word-prop ; : define-syntax ( name quot -- ) - >r "syntax" lookup dup r> define-compound - t "parsing" set-word-prop ; + >r "syntax" lookup dup r> define t "parsing" set-word-prop ; [ { "]" "}" ";" ">>" } [ define-delimiter ] each @@ -96,7 +95,7 @@ IN: bootstrap.syntax ] define-syntax ":" [ - CREATE dup reset-generic parse-definition define-compound + CREATE dup reset-generic parse-definition define ] define-syntax "GENERIC:" [ diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 8a4d17c185..82e3187c75 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -94,7 +94,7 @@ IN: temporary [ ] [ [ - "bob" "vocabs.loader.test.b" create [ ] define-compound + "bob" "vocabs.loader.test.b" create [ ] define ] with-compilation-unit ] unit-test @@ -102,7 +102,7 @@ IN: temporary [ 2 ] [ "count-me" get-global ] unit-test -[ t ] [ "fred" "vocabs.loader.test.b" lookup compound? ] unit-test +[ f ] [ "fred" "vocabs.loader.test.b" lookup undefined? ] unit-test [ ] [ "vocabs.loader.test.b" vocab-files [ forget-source ] each diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 82dce8a241..8d7d5b179b 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -26,18 +26,19 @@ $nl { $subsection gensym } { $subsection define-temp } ; -ARTICLE: "colon-definition" "Compound definitions" -"A compound definition associates a word name with a quotation that is called when the word is executed." -{ $subsection compound } -{ $subsection compound? } -"Defining compound words at parse time:" +ARTICLE: "colon-definition" "Word definitions" +"Every word has an associated quotation definition that is called when the word is executed." +$nl +"Defining words at parse time:" { $subsection POSTPONE: : } { $subsection POSTPONE: ; } -"Defining compound words at run time:" -{ $subsection define-compound } +"Defining words at run time:" +{ $subsection define } { $subsection define-declared } { $subsection define-inline } -"Compound definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "." ; +"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "." +$nl +"All other types of word definitions, such as " { $link "symbols" } " and " { $link "generic" } ", are just special cases of the above." ; ARTICLE: "symbols" "Symbols" "A symbol pushes itself on the stack when executed. By convention, symbols are used as variable names (" { $link "namespaces" } ")." @@ -46,7 +47,12 @@ ARTICLE: "symbols" "Symbols" "Defining symbols at parse time:" { $subsection POSTPONE: SYMBOL: } "Defining symbols at run time:" -{ $subsection define-symbol } ; +{ $subsection define-symbol } +"Symbols are just compound definitions in disguise. The following two lines are equivalent:" +{ $code + "SYMBOL: foo" + ": foo \\ foo ;" +} ; ARTICLE: "primitives" "Primitives" "Primitives are words defined in the Factor VM. They provide the essential low-level services to the rest of the system." @@ -54,11 +60,20 @@ ARTICLE: "primitives" "Primitives" { $subsection primitive? } ; ARTICLE: "deferred" "Deferred words and mutual recursion" -"Words cannot be referenced before they are defined; that is, source files must order definitions in a strictly bottom-up fashion. This is done to simplify the implementation, facilitate better parse time checking and remove some odd corner cases; it also encourages better coding style. Sometimes this restriction gets in the way, for example when defining mutually-recursive words; one way to get around this limitation is to make a forward definition." +"Words cannot be referenced before they are defined; that is, source files must order definitions in a strictly bottom-up fashion. This is done to simplify the implementation, facilitate better parse time checking and remove some odd corner cases; it also encourages better coding style." +$nl +"Sometimes this restriction gets in the way, for example when defining mutually-recursive words; one way to get around this limitation is to make a forward definition." { $subsection POSTPONE: DEFER: } -"The class of forward word definitions:" +"The class of deferred word definitions:" { $subsection deferred } -{ $subsection deferred? } ; +{ $subsection deferred? } +"Deferred words throw an error when called:" +{ $subsection undefined } +"Deferred words are just compound definitions in disguise. The following two lines are equivalent:" +{ $code + "DEFER: foo" + ": foo undefined ;" +} ; ARTICLE: "declarations" "Declarations" "Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word." @@ -155,13 +170,15 @@ ARTICLE: "word.private" "Word implementation details" { $subsection modify-code-heap } ; 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." +"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." +$nl +"Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary." $nl "A word consists of several parts:" { $list "a word name," "a vocabulary name," - "a definition, specifying the behavior of the word when executed," + "a definition quotation, called when the word when executed," "a set of word properties, including documentation and other meta-data." } "Words are instances of a class." @@ -212,9 +229,6 @@ HELP: deferred { deferred POSTPONE: DEFER: } related-words -HELP: compound -{ $description "The class of compound words created by " { $link POSTPONE: : } "." } ; - HELP: primitive { $description "The class of primitive words." } ; @@ -239,20 +253,13 @@ HELP: word-xt { $values { "word" word } { "xt" "an execution token integer" } } { $description "Outputs the machine code address of the word's definition." } ; -HELP: define -{ $values { "word" word } { "def" object } } -{ $description "Defines a word and updates cross-referencing." } -$low-level-note -{ $side-effects "word" } -{ $see-also define-symbol define-compound } ; - HELP: define-symbol { $values { "word" word } } { $description "Defines the word to push itself on the stack when executed. This is the run time equivalent of " { $link POSTPONE: SYMBOL: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "word" } ; -HELP: define-compound +HELP: define { $values { "word" word } { "def" quotation } } { $description "Defines the word to call a quotation when executed. This is the run time equivalent of " { $link POSTPONE: : } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } @@ -342,7 +349,7 @@ HELP: parsing? HELP: define-declared { $values { "word" word } { "def" quotation } { "effect" effect } } -{ $description "Defines a compound word and declares its stack effect." } +{ $description "Defines a word and declares its stack effect." } { $side-effects "word" } ; HELP: define-temp @@ -393,7 +400,7 @@ HELP: make-inline HELP: define-inline { $values { "word" word } { "quot" quotation } } -{ $description "Defines a compound word and makes it " { $link POSTPONE: inline } "." } +{ $description "Defines a word and makes it " { $link POSTPONE: inline } "." } { $side-effects "word" } ; HELP: modify-code-heap ( alist -- ) @@ -401,6 +408,6 @@ HELP: modify-code-heap ( alist -- ) { $description "Stores compiled code definitions in the code heap. The alist maps words to the following:" { $list { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." } - { { $snippet "{ code labels rel words literals profiler-prologue }" } " - in this case, a code heap block is allocated with the given data." } + { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 84297e630d..90108ef01a 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -5,7 +5,7 @@ IN: temporary [ 4 ] [ [ - "poo" "temporary" create [ 2 2 + ] define-compound + "poo" "temporary" create [ 2 2 + ] define ] with-compilation-unit "poo" "temporary" lookup execute ] unit-test @@ -24,8 +24,6 @@ DEFER: plist-test \ plist-test "sample-property" word-prop ] unit-test -[ f ] [ 5 compound? ] unit-test - "create-test" "scratchpad" create { 1 2 } "testing" set-word-prop [ { 1 2 } ] [ "create-test" "scratchpad" lookup "testing" word-prop @@ -46,13 +44,7 @@ DEFER: plist-test [ f ] [ gensym gensym = ] unit-test -[ f ] [ 123 compound? ] unit-test - -: colon-def ; -[ t ] [ \ colon-def compound? ] unit-test - SYMBOL: a-symbol -[ t ] [ \ a-symbol compound? ] unit-test [ t ] [ \ a-symbol symbol? ] unit-test ! See if redefining a generic as a colon def clears some @@ -91,7 +83,7 @@ FORGET: foe ! xref should not retain references to gensyms [ ] [ - [ gensym [ * ] define-compound ] with-compilation-unit + [ gensym [ * ] define ] with-compilation-unit ] unit-test [ t ] [ @@ -103,7 +95,7 @@ DEFER: calls-a-gensym [ \ calls-a-gensym gensym dup "x" set 1quotation - define-compound + define ] with-compilation-unit ] unit-test @@ -143,7 +135,7 @@ SYMBOL: quot-uses-b [ ] [ [ - quot-uses-a [ 2 3 + ] define-compound + quot-uses-a [ 2 3 + ] define ] with-compilation-unit ] unit-test @@ -151,7 +143,7 @@ SYMBOL: quot-uses-b [ ] [ [ - quot-uses-b 2 [ 3 + ] curry define-compound + quot-uses-b 2 [ 3 + ] curry define ] with-compilation-unit ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index d365ffd1db..158ed7ec68 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -17,30 +17,28 @@ M: word execute (execute) ; M: word <=> [ dup word-name swap word-vocabulary 2array ] compare ; -M: word definition drop f ; +M: word definer drop \ : \ ; ; -PREDICATE: word compound ( obj -- ? ) word-def quotation? ; - -M: compound definer drop \ : \ ; ; - -M: compound definition word-def ; +M: word definition word-def ; TUPLE: undefined ; : undefined ( -- * ) \ undefined construct-empty throw ; -PREDICATE: compound deferred ( obj -- ? ) +PREDICATE: word deferred ( obj -- ? ) word-def [ undefined ] = ; M: deferred definer drop \ DEFER: f ; M: deferred definition drop f ; -PREDICATE: compound symbol ( obj -- ? ) +PREDICATE: word symbol ( obj -- ? ) dup 1array swap word-def sequence= ; M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; -PREDICATE: word primitive ( obj -- ? ) word-def fixnum? ; +PREDICATE: word primitive ( obj -- ? ) + word-def [ do-primitive ] tail? ; M: primitive definer drop \ PRIMITIVE: f ; +M: primitive definition drop f ; : word-prop ( word name -- value ) swap word-props at ; @@ -89,26 +87,20 @@ M: wrapper (quot-uses) >r wrapped r> (quot-uses) ; M: word uses ( word -- seq ) word-def quot-uses keys ; -M: compound redefined* ( word -- ) +M: word redefined* ( word -- ) { "inferred-effect" "base-case" "no-effect" } reset-props ; - - -: define-compound ( word def -- ) - [ ] like define ; - : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop - define-compound ; + define ; : make-inline ( word -- ) t "inline" set-word-prop ; @@ -120,7 +112,7 @@ PRIVATE> dup make-flushable t "foldable" set-word-prop ; : define-inline ( word quot -- ) - dupd define-compound make-inline ; + dupd define make-inline ; : define-symbol ( word -- ) dup [ ] curry define-inline ; @@ -142,7 +134,7 @@ PRIVATE> "G:" \ gensym counter number>string append f ; : define-temp ( quot -- word ) - gensym dup rot define-compound ; + gensym dup rot define ; : reveal ( word -- ) dup word-name over word-vocabulary vocab-words set-at ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 30f8d0f29f..a66c1cd31b 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -58,10 +58,7 @@ $nl ARTICLE: "evaluator" "Evaluation semantics" { $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:" { $list - { "a " { $link symbol } " - pushed on the data stack. See " { $link "symbols" } } - { "a " { $link compound } " - the associated definition is called. See " { $link "colon-definition" } } - { "a" { $link primitive } " - a primitive in the Factor VM is called. See " { $link "primitives" } } - { "an " { $link undefined } " - an error is raised. See " { $link "deferred" } } + { "a " { $link word } " - the word's definition quotation is called. See " { $link "words" } } { "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." } { "All other types of objects are pushed on the data stack." } } diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 1c23a1c85e..586156c040 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -13,14 +13,13 @@ IN: macros : (MACRO:) >r 2dup "macro" set-word-prop - 2dup [ call ] append define-compound + 2dup [ call ] append define r> define-transform ; : MACRO: (:) (MACRO:) ; parsing -PREDICATE: compound macro - "macro" word-prop >boolean ; +PREDICATE: word macro "macro" word-prop >boolean ; M: macro definer drop \ MACRO: \ ; ; diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 5406208510..45826724ca 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -4,21 +4,13 @@ USING: kernel words parser io inspector quotations sequences prettyprint continuations effects definitions ; IN: tools.annotations -: check-compound ( word -- ) - compound? [ - "Annotations can only be used with compound words" throw - ] unless ; - : reset ( word -- ) - dup check-compound - dup "unannotated-def" word-prop define-compound ; + dup "unannotated-def" word-prop define ; : annotate ( word quot -- ) - over check-compound over dup word-def "unannotated-def" set-word-prop - [ - >r dup word-def r> call define-compound - ] with-compilation-unit ; inline + [ >r dup word-def r> call define ] with-compilation-unit ; + inline : entering ( str -- ) "/-- Entering: " write dup . diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 53de43b7e5..f438bcd8df 100755 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -41,10 +41,10 @@ M: pair restore dup "step-into" word-prop [ call ] [ - dup compound? [ - word-def walk - ] [ + dup primitive? [ execute break + ] [ + word-def walk ] if ] ?if ; diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 10cc268124..089a3503fd 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -115,7 +115,7 @@ M: quotation com-stack-effect infer. ; M: word com-stack-effect word-def com-stack-effect ; -[ compound? ] \ com-stack-effect H{ +[ word? ] \ com-stack-effect H{ { +listener+ t } } define-operation diff --git a/vm/code_gc.c b/vm/code_gc.c index 7d340f21b0..4c5e3c436f 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -378,8 +378,7 @@ void forward_object_xts(void) { F_WORD *word = untag_object(obj); - if(word_references_code_heap_p(word)) - word->code = forward_xt(word->code); + word->code = forward_xt(word->code); } else if(type_of(obj) == QUOTATION_TYPE) { @@ -411,11 +410,7 @@ void fixup_object_xts(void) if(type_of(obj) == WORD_TYPE) { F_WORD *word = untag_object(obj); - - if(word->compiledp != F) - set_word_xt(word,word->code); - else - word->xt = (void *)(word->code + 1); + update_word_xt(word); } else if(type_of(obj) == QUOTATION_TYPE) { diff --git a/vm/code_heap.c b/vm/code_heap.c index 3f75153baa..9619e0f640 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -36,13 +36,13 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) return undefined_symbol; } -bool profiling_p_; - /* Compute an address to store at a relocation */ INLINE CELL compute_code_rel(F_REL *rel, CELL code_start, CELL literals_start, CELL words_start) { + CELL obj; F_WORD *word; + F_QUOTATION *quot; switch(REL_TYPE(rel)) { @@ -55,26 +55,27 @@ INLINE CELL compute_code_rel(F_REL *rel, case RT_DISPATCH: return CREF(words_start,REL_ARGUMENT(rel)); case RT_XT: - word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - if(word->code) + obj = get(CREF(words_start,REL_ARGUMENT(rel))); + switch(type_of(obj)) { - return (CELL)word->code - + sizeof(F_COMPILED) - + (profiling_p_ ? 0 : word->code->profiler_prologue); - } - else - { - /* Its only NULL in stage 2 early init */ - return 0; + case WORD_TYPE: + word = untag_object(obj); + return (CELL)word->xt; + case QUOTATION_TYPE: + quot = untag_object(obj); + return (CELL)quot->xt; + default: + critical_error("Bad parameter to rt-xt relocation",obj); + return -1; /* Can't happen */ } case RT_XT_PROFILING: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - return (CELL)word->code + sizeof(F_COMPILED); + return (CELL)(word->code + 1); case RT_LABEL: return code_start + REL_ARGUMENT(rel); default: critical_error("Bad rel type",rel->type); - return -1; + return -1; /* Can't happen */ } } @@ -147,8 +148,6 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start, { if(reloc_start != literals_start) { - profiling_p_ = profiling_p(); - F_REL *rel = (F_REL *)reloc_start; F_REL *rel_end = (F_REL *)literals_start; @@ -186,20 +185,6 @@ void fixup_labels(F_ARRAY *labels, CELL code_format, CELL code_start) } } -/* After compiling a batch of words, we replace all mutual word references with -direct XT references, and perform fixups */ -void finalize_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) -{ - if(reloc_start != literals_start) - { - relocate_code_block(relocating,code_start,reloc_start, - literals_start,words_start,words_end); - } - - flush_icache(code_start,reloc_start - code_start); -} - /* Write a sequence of integers to memory, with 'format' bytes per integer */ void deposit_integers(CELL here, F_ARRAY *array, CELL format) { @@ -252,7 +237,6 @@ CELL allot_code_block(CELL size) /* Might GC */ F_COMPILED *add_compiled_block( CELL type, - CELL profiler_prologue, F_ARRAY *code, F_ARRAY *labels, F_ARRAY *relocation, @@ -263,7 +247,7 @@ F_COMPILED *add_compiled_block( CELL code_length = align8(array_capacity(code) * code_format); CELL rel_length = array_capacity(relocation) * sizeof(unsigned int); - CELL words_length = array_capacity(words) * CELLS; + CELL words_length = (words ? array_capacity(words) * CELLS : 0); CELL literals_length = array_capacity(literals) * CELLS; REGISTER_UNTAGGED(code); @@ -288,7 +272,6 @@ F_COMPILED *add_compiled_block( header->reloc_length = rel_length; header->literals_length = literals_length; header->words_length = words_length; - header->profiler_prologue = profiler_prologue; here += sizeof(F_COMPILED); @@ -307,8 +290,11 @@ F_COMPILED *add_compiled_block( here += literals_length; /* words */ - deposit_objects(here,words); - here += words_length; + if(words) + { + deposit_objects(here,words); + here += words_length; + } /* fixup labels */ if(labels) @@ -321,20 +307,26 @@ F_COMPILED *add_compiled_block( return header; } -void set_word_xt(F_WORD *word, F_COMPILED *compiled) +void set_word_code(F_WORD *word, F_COMPILED *compiled) { if(compiled->type != WORD_TYPE) critical_error("bad param to set_word_xt",(CELL)compiled); word->code = compiled; - word->xt = (XT)(compiled + 1); - - if(!profiling_p()) - word->xt += compiled->profiler_prologue; - word->compiledp = T; } +/* Allocates memory */ +void default_word_code(F_WORD *word) +{ + REGISTER_UNTAGGED(word); + jit_compile(word->def); + UNREGISTER_UNTAGGED(word); + + word->code = untag_quotation(word->def)->code; + word->compiledp = F; +} + DEFINE_PRIMITIVE(modify_code_heap) { F_ARRAY *alist = untag_array(dpop()); @@ -356,38 +348,25 @@ DEFINE_PRIMITIVE(modify_code_heap) if(data == F) { - word->compiledp = F; - - if(type_of(word->def) == QUOTATION_TYPE) - { - REGISTER_UNTAGGED(alist); - REGISTER_UNTAGGED(word); - - jit_compile(word->def); - - UNREGISTER_UNTAGGED(word); - UNREGISTER_UNTAGGED(alist); - } - - default_word_xt(word); + REGISTER_UNTAGGED(alist); + default_word_code(word); + UNREGISTER_UNTAGGED(alist); } else { F_ARRAY *compiled_code = untag_array(data); - 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 *relocation = 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)); + F_ARRAY *literals = untag_array(array_nth(compiled_code,0)); + F_ARRAY *words = untag_array(array_nth(compiled_code,1)); + F_ARRAY *relocation = untag_array(array_nth(compiled_code,2)); + F_ARRAY *labels = untag_array(array_nth(compiled_code,3)); + F_ARRAY *code = untag_array(array_nth(compiled_code,4)); REGISTER_UNTAGGED(alist); REGISTER_UNTAGGED(word); F_COMPILED *compiled = add_compiled_block( WORD_TYPE, - profiler_prologue, code, labels, relocation, @@ -397,8 +376,12 @@ DEFINE_PRIMITIVE(modify_code_heap) UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); - set_word_xt(word,compiled); + set_word_code(word,compiled); } + + REGISTER_UNTAGGED(alist); + update_word_xt(word); + UNREGISTER_UNTAGGED(alist); } /* If there were any interned words in the set, we relocate all XT diff --git a/vm/code_heap.h b/vm/code_heap.h index e187f72a4c..4169a0df2f 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -56,11 +56,12 @@ typedef struct { void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end); -void set_word_xt(F_WORD *word, F_COMPILED *compiled); +void default_word_code(F_WORD *word); + +void set_word_code(F_WORD *word, F_COMPILED *compiled); F_COMPILED *add_compiled_block( CELL type, - CELL profiler_prologue, F_ARRAY *code, F_ARRAY *labels, F_ARRAY *rel, diff --git a/vm/data_gc.c b/vm/data_gc.c index 876b30084a..4826c1d1ea 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -521,7 +521,7 @@ CELL binary_payload_start(CELL pointer) return 0; /* these objects have some binary data at the end */ case WORD_TYPE: - return sizeof(F_WORD) - CELLS * 2; + return sizeof(F_WORD) - CELLS * 3; case ALIEN_TYPE: return CELLS * 3; case DLL_TYPE: @@ -534,17 +534,8 @@ CELL binary_payload_start(CELL pointer) } } -void collect_callstack_object(F_CALLSTACK *callstack) +void do_code_slots(CELL scan) { - if(collecting_code) - iterate_callstack_object(callstack,collect_stack_frame); -} - -CELL collect_next(CELL scan) -{ - do_slots(scan,copy_handle); - - /* Special behaviors */ F_WORD *word; F_QUOTATION *quot; F_CALLSTACK *stack; @@ -553,19 +544,28 @@ CELL collect_next(CELL scan) { case WORD_TYPE: word = (F_WORD *)scan; - if(collecting_code && word_references_code_heap_p(word)) - recursive_mark(compiled_to_block(word->code)); + recursive_mark(compiled_to_block(word->code)); + if(word->profiling) + recursive_mark(compiled_to_block(word->profiling)); break; case QUOTATION_TYPE: quot = (F_QUOTATION *)scan; - if(collecting_code && quot->compiledp != F) + if(quot->compiledp != F) recursive_mark(compiled_to_block(quot->code)); break; case CALLSTACK_TYPE: stack = (F_CALLSTACK *)scan; - collect_callstack_object(stack); + iterate_callstack_object(stack,collect_stack_frame); break; } +} + +CELL collect_next(CELL scan) +{ + do_slots(scan,copy_handle); + + if(collecting_code) + do_code_slots(scan); return scan + untagged_object_size(scan); } diff --git a/vm/factor.c b/vm/factor.c index 76c4acc4b9..105fec17e9 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -35,8 +35,6 @@ void do_stage1_init(void) fprintf(stderr,"*** Stage 2 early init... "); fflush(stderr); - jit_compile(userenv[UNDEFINED_ENV]); - begin_scan(); CELL obj; @@ -45,11 +43,8 @@ void do_stage1_init(void) if(type_of(obj) == WORD_TYPE) { F_WORD *word = untag_object(obj); - if(type_of(word->def) == QUOTATION_TYPE) - { - jit_compile(word->def); - default_word_xt(word); - } + default_word_code(word); + update_word_xt(word); } } @@ -79,6 +74,7 @@ void init_factor(F_PARAMETERS *p) /* Disable GC during init as a sanity check */ gc_off = true; + /* OS-specific initialization */ early_init(); if(p->image == NULL) @@ -92,16 +88,15 @@ void init_factor(F_PARAMETERS *p) init_signals(); stack_chain = NULL; + profiling_p = false; + performing_gc = false; + last_code_heap_scan = NURSERY; + collecting_aging_again = false; userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING)); userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING)); userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); - performing_gc = false; - last_code_heap_scan = NURSERY; - collecting_aging_again = false; - stack_chain = NULL; - /* We can GC now */ gc_off = false; diff --git a/vm/image.c b/vm/image.c index 8fc99d7cd9..0f80303749 100755 --- a/vm/image.c +++ b/vm/image.c @@ -175,28 +175,12 @@ DEFINE_PRIMITIVE(save_image_and_exit) void fixup_word(F_WORD *word) { - /* If this is a compiled word, relocate the code pointer. Otherwise, - reset it based on the primitive number of the word. */ - if(word->compiledp == F) + if(stage2) { - if(type_of(word->def) == QUOTATION_TYPE) - { - if(!stage2) - { - /* Word XTs are fixed up in do_stage1_init() */ - return; - } - } - else - { - /* Primitive */ - default_word_xt(word); - return; - } + code_fixup((CELL)&word->code); + if(word->profiling) code_fixup((CELL)&word->profiling); + update_word_xt(word); } - - code_fixup((CELL)&word->xt); - code_fixup((CELL)&word->code); } void fixup_quotation(F_QUOTATION *quot) diff --git a/vm/layouts.h b/vm/layouts.h index 41574ff2f4..7c6d775209 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -152,8 +152,7 @@ typedef struct CELL reloc_length; /* # bytes */ CELL literals_length; /* # bytes */ CELL words_length; /* # bytes */ - CELL profiler_prologue; /* # bytes */ - CELL padding[2]; + CELL padding[3]; } F_COMPILED; /* Assembly code makes assumptions about the layout of this struct */ @@ -178,6 +177,8 @@ typedef struct { XT xt; /* UNTAGGED compiled code block */ F_COMPILED *code; + /* UNTAGGED profiler stub */ + F_COMPILED *profiling; } F_WORD; /* Assembly code makes assumptions about the layout of this struct */ diff --git a/vm/profiler.c b/vm/profiler.c index c42c6925a9..ec4374db52 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -1,31 +1,69 @@ #include "master.h" -bool profiling_p(void) +/* Allocates memory */ +F_COMPILED *compile_profiling_stub(F_WORD *word) { - return to_boolean(userenv[PROFILING_ENV]); + CELL literals = allot_array_1(tag_object(word)); + REGISTER_ROOT(literals); + + F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]); + + CELL code = array_nth(quadruple,0); + REGISTER_ROOT(code); + + CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2)) + | (to_fixnum(array_nth(quadruple,1)) << 8)); + CELL rel_offset = array_nth(quadruple,3); + + CELL relocation = allot_array_2(rel_type,rel_offset); + + UNREGISTER_ROOT(code); + UNREGISTER_ROOT(literals); + + return add_compiled_block( + WORD_TYPE, + untag_object(code), + NULL, /* no labels */ + untag_object(relocation), + NULL, /* no words */ + untag_object(literals)); } -void profiling_word(F_WORD *word) +/* Allocates memory */ +void update_word_xt(F_WORD *word) { /* If we just enabled the profiler, reset call count */ - if(profiling_p()) + if(profiling_p) + { word->counter = tag_fixnum(0); - if(word->compiledp == F) - default_word_xt(word); + if(!word->profiling) + { + REGISTER_UNTAGGED(word); + F_COMPILED *profiling = compile_profiling_stub(word); + UNREGISTER_UNTAGGED(word); + word->profiling = profiling; + } + + word->xt = (XT)(word->profiling + 1); + + printf("%x\n",word->xt); + } else - set_word_xt(word,word->code); + word->xt = (XT)(word->code + 1); } void set_profiling(bool profiling) { - if(profiling == profiling_p()) + if(profiling == profiling_p) return; - userenv[PROFILING_ENV] = tag_boolean(profiling); + profiling_p = profiling; - /* Push everything to tenured space so that we can heap scan */ - data_gc(); + /* Push everything to tenured space so that we can heap scan, + also code GC so that we can allocate profiling blocks if + necessary */ + code_gc(); /* Update word XTs and saved callstack objects */ begin_scan(); @@ -34,7 +72,7 @@ void set_profiling(bool profiling) while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - profiling_word(untag_object(obj)); + update_word_xt(untag_object(obj)); } gc_off = false; /* end heap scan */ diff --git a/vm/profiler.h b/vm/profiler.h old mode 100644 new mode 100755 index 5cb7ea1856..d14ceb283b --- a/vm/profiler.h +++ b/vm/profiler.h @@ -1,2 +1,4 @@ -bool profiling_p(void); +bool profiling_p; DECLARE_PRIMITIVE(profiling); +F_COMPILED *compile_profiling_stub(F_WORD *word); +void update_word_xt(F_WORD *word); diff --git a/vm/quotations.c b/vm/quotations.c index 2468e58822..1010eaf0b0 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -3,6 +3,13 @@ /* Simple JIT compiler. This is one of the two compilers implementing Factor; the second one is written in Factor and performs a lot of optimizations. See core/compiler/compiler.factor */ +bool jit_primitive_call_p(F_ARRAY *array, CELL i) +{ + return (i + 2) == array_capacity(array) + && type_of(array_nth(array,i)) == FIXNUM_TYPE + && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD]; +} + bool jit_fast_if_p(F_ARRAY *array, CELL i) { return (i + 3) == array_capacity(array) @@ -80,7 +87,7 @@ bool jit_stack_frame_p(F_ARRAY *array) void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code) { if(code->type != QUOTATION_TYPE) - critical_error("bad param to set_word_xt",(CELL)code); + critical_error("bad param to set_quot_xt",(CELL)code); quot->code = code; quot->xt = (XT)(code + 1); @@ -113,6 +120,7 @@ void jit_compile(CELL quot) REGISTER_ROOT(words); GROWABLE_ADD(literals,quot); + GROWABLE_ADD(words,quot); bool stack_frame = jit_stack_frame_p(untag_object(array)); @@ -127,7 +135,6 @@ void jit_compile(CELL quot) { CELL obj = array_nth(untag_object(array),i); F_WORD *word; - bool primitive_p; F_WRAPPER *wrapper; switch(type_of(obj)) @@ -137,45 +144,36 @@ void jit_compile(CELL quot) so that we save the C stack pointer minus the current stack frame. */ word = untag_object(obj); - primitive_p = type_of(word->def) == FIXNUM_TYPE; + + GROWABLE_ADD(words,array_nth(untag_object(array),i)); if(i == length - 1) { if(stack_frame) EMIT(JIT_EPILOG,0); - if(primitive_p) - { - EMIT(JIT_WORD_PRIMITIVE_JUMP, - to_fixnum(word->def)); - } - else - { - GROWABLE_ADD(words,array_nth(untag_object(array),i)); - EMIT(JIT_WORD_JUMP,words_count - 1); - } + EMIT(JIT_WORD_JUMP,words_count - 1); tail_call = true; } else - { - if(primitive_p) - { - EMIT(JIT_WORD_PRIMITIVE_CALL, - to_fixnum(word->def)); - } - else - { - GROWABLE_ADD(words,array_nth(untag_object(array),i)); - EMIT(JIT_WORD_CALL,words_count - 1); - } - } + EMIT(JIT_WORD_CALL,words_count - 1); break; case WRAPPER_TYPE: wrapper = untag_object(obj); GROWABLE_ADD(literals,wrapper->object); EMIT(JIT_PUSH_LITERAL,literals_count - 1); break; + case FIXNUM_TYPE: + if(jit_primitive_call_p(untag_object(array),i)) + { + EMIT(JIT_PRIMITIVE,to_fixnum(obj)); + + i++; + + tail_call = true; + break; + } case QUOTATION_TYPE: if(jit_fast_if_p(untag_object(array),i)) { @@ -227,17 +225,18 @@ void jit_compile(CELL quot) F_COMPILED *compiled = add_compiled_block( QUOTATION_TYPE, - 0, untag_object(code), NULL, untag_object(relocation), untag_object(words), untag_object(literals)); - iterate_code_heap_step(compiled,relocate_code_block); - + /* We must do this before relocate_code_block(), so that + relocation knows the quotation's XT. */ set_quot_xt(untag_object(quot),compiled); + iterate_code_heap_step(compiled,relocate_code_block); + UNREGISTER_ROOT(words); UNREGISTER_ROOT(literals); UNREGISTER_ROOT(relocation); @@ -287,24 +286,26 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(stack_frame) COUNT(JIT_EPILOG,i); - if(type_of(word->def) == FIXNUM_TYPE) - COUNT(JIT_WORD_PRIMITIVE_JUMP,i) - else - COUNT(JIT_WORD_JUMP,i) + COUNT(JIT_WORD_JUMP,i) tail_call = true; } else - { - if(type_of(word->def) == FIXNUM_TYPE) - COUNT(JIT_WORD_PRIMITIVE_CALL,i) - else - COUNT(JIT_WORD_CALL,i) - } + COUNT(JIT_WORD_CALL,i) break; case WRAPPER_TYPE: COUNT(JIT_PUSH_LITERAL,i) break; + case FIXNUM_TYPE: + if(jit_primitive_call_p(untag_object(array),i)) + { + COUNT(JIT_PRIMITIVE,i); + + i++; + + tail_call = true; + break; + } case QUOTATION_TYPE: if(jit_fast_if_p(untag_object(array),i)) { diff --git a/vm/run.c b/vm/run.c index c5f16ac190..2e541a5b6c 100755 --- a/vm/run.c +++ b/vm/run.c @@ -259,22 +259,6 @@ DEFINE_PRIMITIVE(set_retainstack) rs = array_to_stack(untag_array(dpop()),rs_bot); } -void default_word_xt(F_WORD *word) -{ - if(type_of(word->def) == QUOTATION_TYPE) - { - F_QUOTATION *quot = untag_quotation(word->def); - if(quot->compiledp == F) - critical_error("default_word_xt invariant lost",0); - word->xt = quot->xt; - word->code = quot->code; - } - else if(type_of(word->def) == FIXNUM_TYPE) - word->xt = primitives[to_fixnum(word->def)]; - else - critical_error("bad word-def",tag_object(word)); -} - DEFINE_PRIMITIVE(getenv) { F_FIXNUM e = untag_fixnum_fast(dpeek()); diff --git a/vm/run.h b/vm/run.h index f7668483ba..dcb3e76bb5 100755 --- a/vm/run.h +++ b/vm/run.h @@ -35,8 +35,8 @@ typedef enum { /* Used by the JIT compiler */ JIT_CODE_FORMAT = 22, JIT_PROLOG, - JIT_WORD_PRIMITIVE_JUMP, - JIT_WORD_PRIMITIVE_CALL, + JIT_PRIMITIVE_WORD, + JIT_PRIMITIVE, JIT_WORD_JUMP, JIT_WORD_CALL, JIT_PUSH_LITERAL, @@ -46,9 +46,9 @@ typedef enum { JIT_DISPATCH, JIT_EPILOG, JIT_RETURN, + JIT_PROFILING, UNDEFINED_ENV = 37, /* default quotation for undefined words */ - PROFILING_ENV = 38, /* is the profiler on? */ STAGE2_ENV = 39 /* have we bootstrapped? */ } F_ENVTYPE; @@ -220,9 +220,6 @@ DECLARE_PRIMITIVE(to_r); DECLARE_PRIMITIVE(from_r); DECLARE_PRIMITIVE(datastack); DECLARE_PRIMITIVE(retainstack); - -void default_word_xt(F_WORD *word); - DECLARE_PRIMITIVE(execute); DECLARE_PRIMITIVE(call); DECLARE_PRIMITIVE(getenv); diff --git a/vm/types.c b/vm/types.c index b5bf1a7449..70d754caea 100755 --- a/vm/types.c +++ b/vm/types.c @@ -164,6 +164,15 @@ DEFINE_PRIMITIVE(to_tuple) drepl(object); } +CELL allot_array_1(CELL obj) +{ + REGISTER_ROOT(obj); + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); + UNREGISTER_ROOT(obj); + set_array_nth(a,0,obj); + return tag_object(a); +} + CELL allot_array_2(CELL v1, CELL v2) { REGISTER_ROOT(v1); @@ -198,7 +207,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill) { int i; F_ARRAY* new_array; - + CELL to_copy = array_capacity(array); if(capacity < to_copy) to_copy = capacity; @@ -212,7 +221,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill) UNREGISTER_UNTAGGED(array); memcpy(new_array + 1,array + 1,to_copy * CELLS); - + for(i = to_copy; i < capacity; i++) set_array_nth(new_array,i,fill); @@ -484,7 +493,6 @@ DEFINE_PRIMITIVE(hashtable) dpush(tag_object(hash)); } -/* ( name vocabulary -- word ) */ F_WORD *allot_word(CELL vocab, CELL name) { REGISTER_ROOT(vocab); @@ -492,6 +500,7 @@ F_WORD *allot_word(CELL vocab, CELL name) F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); UNREGISTER_ROOT(name); UNREGISTER_ROOT(vocab); + word->hashcode = tag_fixnum(rand()); word->vocabulary = vocab; word->name = name; @@ -499,10 +508,20 @@ F_WORD *allot_word(CELL vocab, CELL name) word->props = F; word->counter = tag_fixnum(0); word->compiledp = F; - default_word_xt(word); + word->profiling = NULL; + + REGISTER_UNTAGGED(word); + default_word_code(word); + UNREGISTER_UNTAGGED(word); + + REGISTER_UNTAGGED(word); + update_word_xt(word); + UNREGISTER_UNTAGGED(word); + return word; } +/* ( name vocabulary -- word ) */ DEFINE_PRIMITIVE(word) { CELL vocab = dpop(); @@ -510,6 +529,7 @@ DEFINE_PRIMITIVE(word) dpush(tag_object(allot_word(vocab,name))); } +/* word-xt ( word -- xt ) */ DEFINE_PRIMITIVE(word_xt) { F_WORD *word = untag_word(dpeek()); diff --git a/vm/types.h b/vm/types.h index 38be4b8902..c896b69eba 100755 --- a/vm/types.h +++ b/vm/types.h @@ -109,11 +109,6 @@ INLINE F_QUOTATION *untag_quotation(CELL tagged) return untag_object(tagged); } -INLINE bool word_references_code_heap_p(F_WORD *word) -{ - return (word->compiledp != F || type_of(word->def) == QUOTATION_TYPE); -} - INLINE F_WORD *untag_word(CELL tagged) { type_check(WORD_TYPE,tagged); @@ -133,6 +128,7 @@ F_ARRAY *allot_array_internal(CELL type, CELL capacity); F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill); F_BYTE_ARRAY *allot_byte_array(CELL size); +CELL allot_array_1(CELL obj); CELL allot_array_2(CELL v1, CELL v2); CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); From 96f4f3ff403298aaecfb855737a54f22946f67ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Jan 2008 23:07:25 -0400 Subject: [PATCH 68/82] Fix profiler --- core/cpu/x86/32/bootstrap.factor | 1 + core/cpu/x86/bootstrap.factor | 10 +++++----- vm/profiler.c | 2 -- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index be78b2ce6c..423597eb01 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -8,6 +8,7 @@ IN: bootstrap.x86 : arg0 EAX ; : arg1 EDX ; +: temp-reg EBX ; : stack-reg ESP ; : ds-reg ESI ; : fixnum>slot@ arg0 1 SAR ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index af54b4dd7c..eded516ef2 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -13,15 +13,15 @@ big-endian off [ ! Load word - arg0 0 [] MOV + temp-reg 0 [] MOV ! Bump profiling counter - arg0 profile-count-offset [+] 1 tag-fixnum ADD + temp-reg profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code - arg0 arg0 word-code-offset [+] MOV + temp-reg temp-reg word-code-offset [+] MOV ! Compute word XT - arg0 compiled-header-size ADD + temp-reg compiled-header-size ADD ! Jump to XT - arg0 JMP + temp-reg JMP ] rc-absolute-cell rt-literal 2 jit-profiling jit-define [ diff --git a/vm/profiler.c b/vm/profiler.c index ec4374db52..402f7e2a0d 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -46,8 +46,6 @@ void update_word_xt(F_WORD *word) } word->xt = (XT)(word->profiling + 1); - - printf("%x\n",word->xt); } else word->xt = (XT)(word->code + 1); From 3fd5d8c40e448cf6c1c5858bcf02bcfa28f51140 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Jan 2008 23:07:59 -0400 Subject: [PATCH 69/82] Fixing unit tests --- extra/ui/operations/operations-tests.factor | 4 ++-- extra/ui/tools/listener/listener-tests.factor | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) mode change 100644 => 100755 extra/ui/operations/operations-tests.factor diff --git a/extra/ui/operations/operations-tests.factor b/extra/ui/operations/operations-tests.factor old mode 100644 new mode 100755 index fcb6af012b..efa1ac3f52 --- a/extra/ui/operations/operations-tests.factor +++ b/extra/ui/operations/operations-tests.factor @@ -13,10 +13,10 @@ io.streams.string math help help.markup ; [ "3" ] [ [ 3 "op" get invoke-command ] string-out ] unit-test -[ drop t ] \ my-pprint [ parse ] [ editor-string ] f operation construct-boa +[ drop t ] \ my-pprint [ ] [ editor-string ] f operation construct-boa "op" set -[ "[ 4 ]" ] [ +[ "\"4\"" ] [ [ "4" [ set-editor-string ] keep "op" get invoke-command diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index 4e59fd63ee..2a7ecf0b0f 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -13,8 +13,8 @@ timers [ init-timers ] unless [ ] [ "listener" set ] unit-test "listener" get [ - { "kernel" } [ vocab-words ] map use associate - "listener" get listener-gadget-input set-interactor-vars + { "kernel" } [ vocab-words ] map + "listener" get listener-gadget-input set-interactor-use [ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test @@ -22,14 +22,14 @@ timers [ init-timers ] unless [ \ word-name "listener" get word-completion-string ] unit-test "i" set - H{ } "i" get set-interactor-vars + f "i" get set-interactor-use [ t ] [ "i" get interactor? ] unit-test [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test [ ] [ - "i" get [ "SYMBOL:" parse ] catch go-to-error + "i" get [ { "SYMBOL:" } parse-lines ] catch go-to-error ] unit-test [ t ] [ From c86e95bc30bbb216709e728666ec20079e0c2ae5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Jan 2008 23:08:28 -0400 Subject: [PATCH 70/82] Add some more compiled-usage tests --- core/compiler/compiler.factor | 9 +++++++- core/compiler/test/redefine.factor | 30 +++++++++++++++++++++++++++ core/inference/backend/backend.factor | 6 ++---- 3 files changed, 40 insertions(+), 5 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 5c5c4cf286..0be3aa5362 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -22,11 +22,18 @@ compiled-crossref global [ H{ } assoc-like ] change-at : compiled-usage ( word -- seq ) compiled-crossref get at keys ; +: sensitive? ( word -- ? ) + dup "inline" word-prop + over "infer" word-prop + pick "specializer" word-prop + roll generic? + or or or ; + : compiled-usages ( words -- seq ) compiled-crossref get [ [ over dup set - over "inline" word-prop pick generic? or + over sensitive? [ at namespace swap update ] [ 2drop ] if ] curry each ] H{ } make-assoc keys ; diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 48504a5bac..f059f9ec81 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -143,3 +143,33 @@ DEFER: g-test-7 [ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test [ 138 ] [ g-test-7 ] unit-test + +USE: macros + +DEFER: macro-test-3 + +[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test + +[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) >quotation ;" eval ] unit-test + +[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test + +[ 625 ] [ 5 macro-test-3 ] unit-test + +[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test + +[ 8 ] [ 5 macro-test-3 ] unit-test + +USE: hints + +DEFER: hints-test-2 + +[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test + +[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test + +[ 8 ] [ hints-test-2 ] unit-test + +[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test + +[ 10 ] [ hints-test-2 ] unit-test diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5003336164..e8138577f5 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -76,7 +76,7 @@ GENERIC: apply-object ( obj -- ) M: object apply-object apply-literal ; -M: wrapper apply-object wrapped apply-literal ; +M: wrapper apply-object wrapped dup depends-on apply-literal ; : terminate ( -- ) terminated? on #terminate node, ; @@ -336,7 +336,6 @@ TUPLE: unbalanced-branches-error quots in out ; recursive-label #call-label [ consume/produce ] keep set-node-in-d ] [ - dup depends-on over effect-in length reify-curries #call consume/produce ] if ; @@ -437,7 +436,6 @@ M: #call-label collect-recursion* [ set ] 2each ; : inline-word ( word -- ) - dup depends-on dup inline-block over recursive-label? [ flatten-meta-d >r drop join-values inline-block apply-infer @@ -451,7 +449,7 @@ M: #call-label collect-recursion* ] if ; M: word apply-object - [ + dup depends-on [ dup inline-recursive-label [ declared-infer ] [ inline-word ] if ] [ From 55efffed6c889cc14182035af1cf94214da250e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Jan 2008 22:10:49 -0400 Subject: [PATCH 71/82] Make mixins smarter, fix interactor --- core/classes/classes-tests.factor | 34 +++++++++++- core/classes/classes.factor | 4 +- core/classes/mixin/mixin.factor | 54 ++++++++++++++++--- core/definitions/definitions-docs.factor | 2 +- core/definitions/definitions.factor | 10 ++++ core/prettyprint/prettyprint-tests.factor | 14 ++--- core/prettyprint/prettyprint.factor | 18 ++++--- core/syntax/syntax.factor | 6 ++- extra/ui/gestures/gestures.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 32 +++++------ extra/ui/tools/listener/listener-tests.factor | 10 ++-- extra/ui/tools/listener/listener.factor | 6 +-- 12 files changed, 140 insertions(+), 52 deletions(-) mode change 100644 => 100755 core/classes/mixin/mixin.factor diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 592691f6c7..c88141fd76 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ quotation redefine-bug-2 class< ] unit-test [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test -"IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval +[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test [ t ] [ bignum redefine-bug-1 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test @@ -173,3 +173,35 @@ FORGET: forget-class-bug-1 FORGET: forget-class-bug-2 [ t ] [ integer dll class-or interned? ] unit-test + +DEFER: mixin-forget-test-g + +[ ] [ + { + "USING: sequences ;" + "IN: temporary" + "MIXIN: mixin-forget-test" + "INSTANCE: sequence mixin-forget-test" + "GENERIC: mixin-forget-test-g ( x -- y )" + "M: mixin-forget-test mixin-forget-test-g ;" + } "\n" join "mixin-forget-test" + parse-stream drop +] unit-test + +[ { } ] [ { } mixin-forget-test-g ] unit-test +[ H{ } mixin-forget-test-g ] unit-test-fails + +[ ] [ + { + "USING: hashtables ;" + "IN: temporary" + "MIXIN: mixin-forget-test" + "INSTANCE: hashtable mixin-forget-test" + "GENERIC: mixin-forget-test-g ( x -- y )" + "M: mixin-forget-test mixin-forget-test-g ;" + } "\n" join "mixin-forget-test" + parse-stream drop +] unit-test + +[ { } mixin-forget-test-g ] unit-test-fails +[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ac40bc3a1a..63abec56f8 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -239,8 +239,6 @@ M: word uncache-class drop ; : uncache-classes ( assoc -- ) [ drop uncache-class ] assoc-each ; -GENERIC: update-methods ( class -- ) - PRIVATE> : define-class-props ( members superclass metaclass -- assoc ) @@ -265,7 +263,7 @@ PRIVATE> uncache-classes dupd (define-class) ] keep cache-classes - r> [ update-methods ] [ drop ] if ; + r> [ changed-class ] [ drop ] if ; GENERIC: class ( object -- class ) inline diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor old mode 100644 new mode 100755 index 4ea6f430b3..a60a51c948 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.union words kernel sequences ; +USING: classes classes.union words kernel sequences +definitions prettyprint.backend ; IN: classes.mixin PREDICATE: union-class mixin-class "mixin" word-prop ; @@ -19,11 +20,48 @@ M: mixin-class reset-class { } redefine-mixin-class ] if ; +TUPLE: check-mixin-class mixin ; + +: check-mixin-class ( mixin -- mixin ) + dup mixin-class? [ + \ check-mixin-class construct-boa throw + ] unless ; + +: if-mixin-member? ( class mixin true false -- ) + >r >r check-mixin-class 2dup members memq? r> r> if ; inline + +: change-mixin-class ( class mixin quot -- ) + [ members swap bootstrap-word ] swap compose keep + swap redefine-mixin-class ; inline + : add-mixin-instance ( class mixin -- ) - dup mixin-class? [ "Not a mixin class" throw ] unless - 2dup members memq? [ - 2drop - ] [ - [ members swap bootstrap-word add ] keep swap - redefine-mixin-class - ] if ; + [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ; + +: remove-mixin-instance ( class mixin -- ) + [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ; + +! Definition protocol implementation ensures that removing an +! INSTANCE: declaration from a source file updates the mixin. +TUPLE: mixin-instance loc class mixin ; + +: ( class mixin -- definition ) + { set-mixin-instance-class set-mixin-instance-mixin } + mixin-instance construct ; + +M: mixin-instance where mixin-instance-loc ; + +M: mixin-instance set-where set-mixin-instance-loc ; + +M: mixin-instance synopsis* + \ INSTANCE: pprint-word + dup mixin-instance-class pprint-word + mixin-instance-mixin pprint-word ; + +M: mixin-instance definer drop \ INSTANCE: f ; + +M: mixin-instance definition drop f ; + +M: mixin-instance forget + dup mixin-instance-class + swap mixin-instance-mixin + remove-mixin-instance ; diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index f8eeafd505..acd5e95709 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -14,7 +14,7 @@ $nl { $subsection uses } "When a definition is changed, all definitions which depend on it are notified via a hook:" { $subsection redefined* } -"Definitions must implement a few operations used for printing them in human and computer-readable form:" +"Definitions must implement a few operations used for printing them in source form:" { $subsection synopsis* } { $subsection definer } { $subsection definition } ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 76ee8c89f0..055d969e66 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -44,7 +44,10 @@ M: object redefined* drop ; : delete-xref ( defspec -- ) dup unxref crossref get delete-at ; +GENERIC: update-methods ( class -- ) + SYMBOL: changed-words +SYMBOL: changed-classes SYMBOL: old-definitions SYMBOL: new-definitions @@ -91,12 +94,19 @@ TUPLE: no-compilation-unit word ; [ no-compilation-unit ] unless* set-at ; +: changed-class ( class -- ) + dup changed-classes get + [ no-compilation-unit ] unless* + set-at ; + : with-compilation-unit ( quot -- ) [ H{ } clone changed-words set + H{ } clone changed-classes set new-definitions set old-definitions set [ + changed-classes get keys [ update-methods ] each changed-words get keys recompile-hook get call ] [ ] cleanup ] with-scope ; inline diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 0d7b19c837..bbb63db499 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -148,7 +148,7 @@ unit-test { "USING: io kernel sequences words ;" "IN: temporary" - ": retain-stack-layout" + ": retain-stack-layout ( x -- )" " dup stream-readln stream-readln" " >r [ define ] map r>" " define ;" @@ -162,7 +162,7 @@ unit-test { "USING: kernel math sequences strings ;" "IN: temporary" - ": soft-break-layout" + ": soft-break-layout ( x y -- ? )" " over string? [" " over hashcode over hashcode number=" " [ sequence= ] [ 2drop f ] if" @@ -204,7 +204,7 @@ unit-test { "USING: io kernel parser ;" "IN: temporary" - ": string-layout-test" + ": string-layout-test ( error -- )" " \"Expected \" write dup unexpected-want expected>string write" " \" but got \" write unexpected-got expected>string print ;" } ; @@ -256,7 +256,7 @@ unit-test : another-narrow-test { "IN: temporary" - ": another-narrow-layout" + ": another-narrow-layout ( -- obj )" " H{" " { 1 2 }" " { 3 4 }" @@ -275,8 +275,10 @@ unit-test : class-see-test { "IN: temporary" - "TUPLE: class-see-layout bar ;" - "GENERIC: class-see-layout" + "TUPLE: class-see-layout ;" + "" + "IN: temporary" + "GENERIC: class-see-layout ( x -- y )" "" "USING: temporary ;" "M: class-see-layout class-see-layout ;" diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index cc19a67bfa..c0ce3b45bd 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -249,14 +249,17 @@ M: word see-class* drop ; M: builtin-class see-class* drop "! Built-in class" comment. ; -: see-all ( seq -- ) natural-sort [ nl see ] each ; +: see-all ( seq -- ) + natural-sort [ nl see ] each ; : see-implementors ( class -- seq ) dup implementors [ 2array ] curry* map ; : see-class ( class -- ) dup class? [ - dup seeing-word dup see-class* + [ + dup seeing-word dup see-class* + ] with-use nl ] when drop ; : see-methods ( generic -- seq ) @@ -264,10 +267,13 @@ M: builtin-class see-class* [ 2array ] curry map ; M: word see - [ - dup see-class - dup class? over symbol? and not [ dup (see) ] when - ] with-use nl + dup see-class + dup class? over symbol? not and [ + nl + ] when + dup class? over symbol? and not [ + [ dup (see) ] with-use nl + ] when [ dup class? [ dup see-implementors % ] when dup generic? [ dup see-methods % ] when diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 85abd228cb..b74f25a6e4 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -134,7 +134,11 @@ IN: bootstrap.syntax CREATE-CLASS define-mixin-class ] define-syntax - "INSTANCE:" [ scan-word scan-word add-mixin-instance ] define-syntax + "INSTANCE:" [ + location >r + scan-word scan-word 2dup add-mixin-instance + r> remember-definition + ] define-syntax "PREDICATE:" [ scan-word diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 3d1e7baf7f..d675f1873a 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -115,7 +115,7 @@ drag-timer construct-empty drag-timer set-global : start-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global 100 100 add-timer + drag-timer get-global 100 300 add-timer ] when ; : stop-drag-timer ( -- ) diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index fe8c85d04b..f407cd8470 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -11,9 +11,13 @@ IN: ui.tools.interactor TUPLE: interactor history output continuation quot busy? -use help ; +: interactor-use ( interactor -- seq ) + use swap + interactor-continuation continuation-name + assoc-stack ; + : init-caret-help ( interactor -- ) dup editor-caret 100 swap set-interactor-help ; @@ -67,11 +71,13 @@ M: interactor model-changed t over set-interactor-busy? interactor-continuation schedule-thread-with ; +: clear-input ( interactor -- ) gadget-model clear-doc ; + : interactor-finish ( interactor -- ) [ editor-string ] keep [ interactor-input. ] 2keep [ add-interactor-history ] keep - gadget-model clear-doc ; + clear-input ; : interactor-eof ( interactor -- ) dup interactor-busy? [ @@ -108,9 +114,6 @@ M: interactor stream-read M: interactor stream-read-partial stream-read ; -: save-use ( interactor -- ) - use get swap set-interactor-use ; - : go-to-error ( interactor error -- ) dup parse-error-line 1- swap parse-error-col 2array over set-caret @@ -122,7 +125,7 @@ M: interactor stream-read-partial : try-parse ( lines interactor -- quot/error/f ) [ - >r parse-lines-interactive r> save-use + drop parse-lines-interactive ] [ >r f swap set-interactor-busy? drop r> dup delegate unexpected-eof? [ drop f ] when @@ -136,19 +139,18 @@ M: interactor stream-read-partial } cond ; M: interactor stream-read-quot - [ save-use ] keep - [ interactor-yield ] keep over quotation? [ - drop - ] [ - [ handle-interactive ] keep swap - [ interactor-finish ] [ nip stream-read-quot ] if - ] if ; + [ interactor-yield ] keep { + { [ over not ] [ drop ] } + { [ over callable? ] [ drop ] } + { [ t ] [ + [ handle-interactive ] keep swap + [ interactor-finish ] [ nip stream-read-quot ] if + ] } + } cond ; M: interactor pref-dim* 0 over line-height 4 * 2array swap delegate pref-dim* vmax ; -: clear-input gadget-model clear-doc ; - interactor "interactor" f { { T{ key-down f f "RET" } evaluate-input } { T{ key-down f { C+ } "k" } clear-input } diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index 2a7ecf0b0f..eab85209cc 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -1,7 +1,7 @@ USING: continuations documents ui.tools.interactor ui.tools.listener hashtables kernel namespaces parser sequences timers tools.test ui.commands ui.gadgets ui.gadgets.editors -ui.gadgets.panes vocabs words tools.test.ui ; +ui.gadgets.panes vocabs words tools.test.ui slots.private ; IN: temporary timers [ init-timers ] unless @@ -13,16 +13,12 @@ timers [ init-timers ] unless [ ] [ "listener" set ] unit-test "listener" get [ - { "kernel" } [ vocab-words ] map - "listener" get listener-gadget-input set-interactor-use - [ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test - [ "USE: words word-name" ] - [ \ word-name "listener" get word-completion-string ] unit-test + [ "USE: slots.private slot" ] + [ \ slot "listener" get word-completion-string ] unit-test "i" set - f "i" get set-interactor-use [ t ] [ "i" get interactor? ] unit-test diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 88901b4664..f96fdf8875 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -97,9 +97,9 @@ M: listener-operation invoke-command ( target command -- ) listener-gadget-input user-input ; : quot-action ( interactor -- lines ) - dup control-value swap - 2dup add-interactor-history - select-all ; + dup control-value + dup "\n" join pick add-interactor-history + swap select-all ; TUPLE: stack-display ; From 516eca854406f435af188b9e5c435ec37e607af7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jan 2008 16:09:55 -0400 Subject: [PATCH 72/82] Fix interactor stack effect inference --- extra/ui/tools/interactor/interactor.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index f407cd8470..ae1b61f06c 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators continuations documents ui.tools.workspace hashtables io io.styles kernel math @@ -74,10 +74,11 @@ M: interactor model-changed : clear-input ( interactor -- ) gadget-model clear-doc ; : interactor-finish ( interactor -- ) + #! The in-thread is a kludge to make it infer. Stupid. [ editor-string ] keep [ interactor-input. ] 2keep [ add-interactor-history ] keep - clear-input ; + [ clear-input ] curry in-thread ; : interactor-eof ( interactor -- ) dup interactor-busy? [ From c3deb44f436264c240cd6e0a9b34389beb2a0402 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jan 2008 18:27:15 -0400 Subject: [PATCH 73/82] Fix circularity --- core/alien/alien.factor | 25 +- core/arrays/arrays-docs.factor | 11 +- core/bit-arrays/bit-arrays.factor | 4 +- core/byte-arrays/byte-arrays-docs.factor | 3 +- core/byte-arrays/byte-arrays.factor | 8 +- core/float-arrays/float-arrays.factor | 6 +- core/sequences/sequences-docs.factor | 7 +- core/vocabs/loader/loader.factor | 20 +- extra/bootstrap/help/help.factor | 22 +- extra/destructors/destructors-docs.factor | 5 +- extra/help/handbook/handbook.factor | 9 +- extra/help/help-docs.factor | 244 +++++++++++++++++- extra/help/markup/markup-docs.factor | 206 --------------- extra/help/syntax/syntax-docs.factor | 35 --- extra/io/launcher/launcher-docs.factor | 2 +- extra/math/vectors/vectors-docs.factor | 4 + extra/qualified/qualified-docs.factor | 3 +- extra/shuffle/shuffle-docs.factor | 165 ++++++------ extra/ui/freetype/freetype-docs.factor | 7 +- extra/ui/gadgets/books/books-docs.factor | 4 +- extra/ui/gadgets/buttons/buttons-docs.factor | 10 +- extra/ui/gadgets/frames/frames-docs.factor | 6 +- extra/ui/gadgets/gadgets-docs.factor | 3 +- .../gadgets/grid-lines/grid-lines-docs.factor | 5 +- extra/ui/gadgets/grids/grids-docs.factor | 4 +- .../incremental/incremental-docs.factor | 4 +- extra/ui/gadgets/menus/menus-docs.factor | 9 +- extra/ui/gadgets/packs/packs-docs.factor | 5 +- .../presentations/presentations-docs.factor | 6 +- .../gadgets/scrollers/scrollers-docs.factor | 4 +- .../gadgets/status-bar/status-bar-docs.factor | 5 +- extra/ui/gadgets/tracks/tracks-docs.factor | 5 +- .../gadgets/viewports/viewports-docs.factor | 4 +- extra/ui/gadgets/worlds/worlds-docs.factor | 8 +- extra/ui/tools/debugger/debugger-docs.factor | 5 +- extra/ui/tools/deploy/deploy-docs.factor | 3 +- .../tools/interactor/interactor-docs.factor | 5 +- 37 files changed, 447 insertions(+), 434 deletions(-) mode change 100644 => 100755 core/alien/alien.factor mode change 100644 => 100755 core/byte-arrays/byte-arrays-docs.factor mode change 100644 => 100755 core/byte-arrays/byte-arrays.factor mode change 100644 => 100755 core/float-arrays/float-arrays.factor delete mode 100644 extra/help/markup/markup-docs.factor delete mode 100644 extra/help/syntax/syntax-docs.factor mode change 100644 => 100755 extra/io/launcher/launcher-docs.factor mode change 100644 => 100755 extra/qualified/qualified-docs.factor mode change 100644 => 100755 extra/shuffle/shuffle-docs.factor mode change 100644 => 100755 extra/ui/freetype/freetype-docs.factor mode change 100644 => 100755 extra/ui/gadgets/buttons/buttons-docs.factor mode change 100644 => 100755 extra/ui/gadgets/frames/frames-docs.factor mode change 100644 => 100755 extra/ui/gadgets/grid-lines/grid-lines-docs.factor mode change 100644 => 100755 extra/ui/gadgets/grids/grids-docs.factor mode change 100644 => 100755 extra/ui/gadgets/incremental/incremental-docs.factor mode change 100644 => 100755 extra/ui/gadgets/menus/menus-docs.factor mode change 100644 => 100755 extra/ui/gadgets/packs/packs-docs.factor mode change 100644 => 100755 extra/ui/gadgets/presentations/presentations-docs.factor mode change 100644 => 100755 extra/ui/gadgets/scrollers/scrollers-docs.factor mode change 100644 => 100755 extra/ui/gadgets/status-bar/status-bar-docs.factor mode change 100644 => 100755 extra/ui/gadgets/tracks/tracks-docs.factor mode change 100644 => 100755 extra/ui/gadgets/worlds/worlds-docs.factor mode change 100644 => 100755 extra/ui/tools/debugger/debugger-docs.factor mode change 100644 => 100755 extra/ui/tools/deploy/deploy-docs.factor diff --git a/core/alien/alien.factor b/core/alien/alien.factor old mode 100644 new mode 100755 index 32157dcb90..3dc1fbfb86 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,16 +1,24 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: alien USING: assocs kernel math namespaces sequences system -byte-arrays bit-arrays float-arrays kernel.private tuples ; +kernel.private tuples ; +IN: alien ! Some predicate classes used by the compiler for optimization ! purposes PREDICATE: alien simple-alien underlying-alien not ; -UNION: simple-c-ptr - simple-alien byte-array bit-array float-array POSTPONE: f ; +! These mixins are not intended to be extended by user code. +! They are not unions, because if they were we'd have a circular +! dependency between alien and {byte,bit,float}-arrays. +MIXIN: simple-c-ptr +INSTANCE: simple-alien simple-c-ptr +INSTANCE: f simple-c-ptr + +MIXIN: c-ptr +INSTANCE: alien c-ptr +INSTANCE: f c-ptr DEFER: pinned-c-ptr? @@ -20,9 +28,6 @@ PREDICATE: alien pinned-alien UNION: pinned-c-ptr pinned-alien POSTPONE: f ; -UNION: c-ptr - alien bit-array byte-array float-array POSTPONE: f ; - M: f expired? drop t ; : ( address -- alien ) @@ -47,9 +52,7 @@ M: alien equal? SYMBOL: libraries -global [ - libraries [ H{ } assoc-like ] change -] bind +libraries global [ H{ } assoc-like ] change-at TUPLE: library path abi dll ; diff --git a/core/arrays/arrays-docs.factor b/core/arrays/arrays-docs.factor index ff2a61473c..39fed147cf 100755 --- a/core/arrays/arrays-docs.factor +++ b/core/arrays/arrays-docs.factor @@ -1,6 +1,5 @@ -USING: byte-arrays bit-arrays help.markup help.syntax -kernel kernel.private prettyprint strings sbufs vectors -quotations sequences.private ; +USING: help.markup help.syntax +kernel kernel.private prettyprint sequences.private ; IN: arrays ARTICLE: "arrays" "Arrays" @@ -34,16 +33,10 @@ HELP: ( n elt -- array ) { $values { "n" "a non-negative integer" } { "elt" "an initial element" } { "array" "a new array" } } { $description "Creates a new array with the given length and all elements initially set to " { $snippet "elt" } "." } ; -{ } -related-words - HELP: >array { $values { "seq" "a sequence" } { "array" array } } { $description "Outputs a freshly-allocated array with the same elements as a given sequence." } ; -{ >array >quotation >string >sbuf >vector >byte-array >bit-array } -related-words - HELP: 1array { $values { "x" object } { "array" array } } { $description "Create a new array with one element." } ; diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index d1eb7802ef..d5257e8493 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math alien kernel kernel.private sequences sequences.private ; @@ -49,3 +49,5 @@ M: bit-array equal? over bit-array? [ sequence= ] [ 2drop f ] if ; INSTANCE: bit-array sequence +INSTANCE: bit-array simple-c-ptr +INSTANCE: bit-array c-ptr diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor old mode 100644 new mode 100755 index d26ab68a9c..27df8771c3 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -1,5 +1,4 @@ -USING: arrays bit-arrays vectors strings sbufs -kernel help.markup help.syntax ; +USING: help.markup help.syntax ; IN: byte-arrays ARTICLE: "byte-arrays" "Byte arrays" diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor old mode 100644 new mode 100755 index 0d4eda138d..f82569c270 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel kernel.private alien sequences sequences.private +math ; IN: byte-arrays -USING: kernel kernel.private alien sequences -sequences.private math ; M: byte-array clone (clone) ; M: byte-array length array-capacity ; @@ -16,3 +16,5 @@ M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; INSTANCE: byte-array sequence +INSTANCE: byte-array simple-c-ptr +INSTANCE: byte-array c-ptr diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor old mode 100644 new mode 100755 index 36ffabb611..ba0b2bb61d --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: float-arrays USING: kernel kernel.private alien sequences sequences.private math math.private ; +IN: float-arrays ; flushable diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 072fc0da08..fbb879b01e 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1,6 +1,5 @@ USING: arrays bit-arrays help.markup help.syntax -sequences.private vectors strings sbufs kernel math math.vectors -; +sequences.private vectors strings sbufs kernel math ; IN: sequences ARTICLE: "sequences-unsafe" "Unsafe sequence operations" @@ -483,14 +482,12 @@ HELP: 2reduce { $snippet "( prev elt1 elt2 -- next )" } } { "result" "the final result" } } { $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } -{ $examples "The " { $link v. } " word provides a particularly elegant implementation of the dot product." } { $notes "If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." } ; HELP: 2map { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } } { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } -{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } -{ $see-also v+ v- v* v/ } ; +{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ; HELP: 2all? { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } } diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index bb4e47d929..f8049de4cd 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -68,11 +68,9 @@ SYMBOL: load-help? : source-wasn't-loaded f swap set-vocab-source-loaded? ; : load-source ( root name -- ) - [ source-was-loaded ] keep [ - [ vocab-source path+ bootstrap-file ] - [ ] [ source-wasn't-loaded ] - cleanup - ] keep source-was-loaded ; + [ source-wasn't-loaded ] keep + [ vocab-source path+ bootstrap-file ] keep + source-was-loaded ; : docs-were-loaded t swap set-vocab-docs-loaded? ; @@ -80,14 +78,10 @@ SYMBOL: load-help? : load-docs ( root name -- ) load-help? get [ - [ docs-were-loaded ] keep [ - [ vocab-docs path+ ?run-file ] - [ ] [ docs-weren't-loaded ] - cleanup - ] keep docs-were-loaded - ] [ - 2drop - ] if ; + [ docs-weren't-loaded ] keep + [ vocab-docs path+ ?run-file ] keep + docs-were-loaded + ] [ 2drop ] if ; : amend-vocab-from-root ( root name -- vocab ) dup vocab-source-loaded? [ 2dup load-source ] unless diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor index a7a4408ed1..13e9adf651 100755 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -6,16 +6,18 @@ IN: bootstrap.help : load-help t load-help? set-global - vocabs - [ vocab-root ] subset - [ vocab-source-loaded? ] subset - [ - dup vocab-docs-loaded? [ - drop - ] [ - dup vocab-root swap load-docs - ] if - ] each + [ vocab ] load-vocab-hook [ + vocabs + [ vocab-root ] subset + [ vocab-source-loaded? ] subset + [ + dup vocab-docs-loaded? [ + drop + ] [ + dup vocab-root swap load-docs + ] if + ] each + ] with-variable "help.handbook" require ; diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index 695e3ed950..4c51e7ddfb 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax libc kernel destructors ; +USING: help.markup help.syntax libc kernel ; IN: destructors HELP: free-always @@ -27,5 +27,4 @@ HELP: with-destructors { $notes "Destructors are not allowed to throw exceptions. No exceptions." } { $examples { $code "[ 10 malloc free-always ] with-destructors" } -} -{ $see-also } ; +} ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index a66c1cd31b..772345a243 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -1,7 +1,8 @@ USING: help help.markup help.syntax help.topics namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io tools.browser -generic math tools.profiler system ui ; +generic math tools.profiler system ui strings sbufs vectors +byte-arrays bit-arrays float-arrays quotations ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -345,3 +346,9 @@ ARTICLE: "changes" "Changes in the latest release" "Solaris/x86 fixes. (Samuel Tardieu)" "Linux/AMD64 port works again." } ; + +{ } +related-words + +{ >array >quotation >string >sbuf >vector >byte-array >bit-array >float-array } +related-words diff --git a/extra/help/help-docs.factor b/extra/help/help-docs.factor index 0323287a9a..2be3f65c4b 100755 --- a/extra/help/help-docs.factor +++ b/extra/help/help-docs.factor @@ -1,5 +1,6 @@ -USING: help.markup help.crossref help.topics help.syntax -definitions io prettyprint inspector arrays math ; +USING: help.markup help.crossref help.stylesheet help.topics +help.syntax definitions io prettyprint inspector arrays math +sequences vocabs ; IN: help ARTICLE: "printing-elements" "Printing markup elements" @@ -59,6 +60,9 @@ ARTICLE: "element-types" "Element types" { $subsection "block-elements" } { $subsection "markup-utils" } ; +IN: help.markup +ABOUT: "element-types" + ARTICLE: "browsing-help" "Browsing documentation" "The easiest way to browse the help is from the help browser tool in the UI, however you can also display help topics in the listener. Help topics are identified by article name strings, or words. You can request a specific help topic:" { $subsection help } @@ -112,6 +116,7 @@ ARTICLE: "help" "Help system" { $subsection "help.lint" } { $subsection "help-impl" } ; +IN: help ABOUT: "help" HELP: $title @@ -161,4 +166,239 @@ HELP: $predicate { $values { "element" "a markup element of the form " { $snippet "{ word }" } } } { $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ; +HELP: print-element +{ $values { "element" "a markup element" } } +{ $description "Prints a markup element to the " { $link stdio } " stream." } ; + +HELP: print-content +{ $values { "element" "a markup element" } } +{ $description "Prints a top-level markup element to the " { $link stdio } " stream." } ; + +HELP: simple-element +{ $class-description "Class of simple elements, which are just arrays of elements." } ; + +HELP: ($span) +{ $values { "quot" "a quotation" } } +{ $description "Prints an inline markup element." } ; + +HELP: ($block) +{ $values { "quot" "a quotation" } } +{ $description "Prints a block markup element with newlines before and after." } ; + +HELP: $heading +{ $values { "element" "a markup element" } } +{ $description "Prints a markup element, usually a string, as a block with the " { $link heading-style } "." } +{ $examples + { $markup-example { $heading "What remains to be discovered" } } +} ; + +HELP: $subheading +{ $values { "element" "a markup element of the form " { $snippet "{ title content }" } } } +{ $description "Prints a markup element, usually a string, as a block with the " { $link strong-style } "." } +{ $examples + { $markup-example { $subheading "Developers, developers, developers!" } } +} ; + +HELP: $code +{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } } +{ $description "Prints code examples, as seen in many help articles. The markup element must be an array of strings." } +{ $notes + "The code becomes clickable if the output stream supports it, and clicking it opens a listener window with the text inserted at the input prompt." + $nl + "If you want to show code along with sample output, use the " { $link $example } " element." +} +{ $examples + { $markup-example { $code "2 2 + ." } } +} ; + +HELP: $vocabulary +{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } } +{ $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ; + +HELP: $description +{ $values { "element" "a markup element" } } +{ $description "Prints the description subheading found on the help page of most words." } ; + +HELP: $contract +{ $values { "element" "a markup element" } } +{ $description "Prints a heading followed by a contract, found on the help page of generic words. Every generic word should document a contract which specifies method behavior that callers can rely upon, and implementations must obey." } +{ $examples + { $markup-example { $contract "Methods of this generic word must always crash." } } +} ; + +HELP: $examples +{ $values { "element" "a markup element" } } +{ $description "Prints a heading followed by some examples. Word documentation should include examples, at least if the usage of the word is not entirely obvious." } +{ $examples + { $markup-example { $examples { $example "2 2 + ." "4" } } } +} ; + +HELP: $example +{ $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } } +{ $description "Prints a clickable example with sample output. The markup element must be an array of strings. All but the last string are joined by newlines and taken as the input text, and the last string is the output. The example becomes clickable if the output stream supports it, and clicking it opens a listener window with the input text inserted at the input prompt." } +{ $examples + "The output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:" + { $markup-example { $unchecked-example "2 2 +" "4" } } + "However the following is right:" + { $markup-example { $example "2 2 + ." "4" } } + "Examples can incorporate a call to " { $link .s } " to show multiple output values; the convention is that you may assume the stack is empty before the example evaluates." +} ; + +HELP: $markup-example +{ $values { "element" "a markup element" } } +{ $description "Prints a clickable example showing the prettyprinted source text of " { $snippet "element" } " followed by rendered output. The example becomes clickable if the output stream supports it." } +{ $examples + { $markup-example { $markup-example { $emphasis "Hi" } } } +} ; + +HELP: $warning +{ $values { "element" "a markup element" } } +{ $description "Prints an element inset in a block styled as so to draw the reader's attention towards it." } +{ $examples + { $markup-example { $warning "Incorrect use of this product may cause serious injury or death." } } +} ; + +HELP: $link +{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } } +{ $description "Prints a link to a help article or word." } +{ $examples + { $markup-example { $link "dlists" } } + { $markup-example { $link + } } +} ; + +HELP: textual-list +{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." } +{ $examples + { $example "USE: help.markup" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } +} ; + +HELP: $links +{ $values { "topics" "a sequence of article names or words" } } +{ $description "Prints a series of links to help articles or word documentation." } +{ $notes "This markup element is used to implement " { $link $links } "." } +{ $examples + { $markup-example { $links + - * / } } +} ; + +HELP: $see-also +{ $values { "topics" "a sequence of article names or words" } } +{ $description "Prints a heading followed by a series of links." } +{ $examples + { $markup-example { $see-also "graphs" "dlists" } } +} ; + +{ $see-also $related related-words } related-words + +HELP: $table +{ $values { "element" "an array of arrays of markup elements" } } +{ $description "Prints a table given as an array of rows, where each row must have the same number of columns." } +{ $examples + { $markup-example + { $table + { "a" "b" "c" } + { "d" "e" "f" } + } + } +} ; + +HELP: $values +{ $values { "element" "an array of pairs of markup elements" } } +{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder can be an element of any form." } ; + +HELP: $list +{ $values { "element" "an array of markup elements" } } +{ $description "Prints a bulleted list of markup elements." } +{ $notes + "A common mistake is that if an item consists of more than just a string, it will be broken up as several items:" + { $markup-example + { $list + "First item" + "Second item " { $emphasis "with emphasis" } + } + } + "The fix is easy; just group the two markup elements making up the second item into one markup element:" + { $markup-example + { $list + "First item" + { "Second item " { $emphasis "with emphasis" } } + } + } +} ; + +HELP: $errors +{ $values { "element" "a markup element" } } +{ $description "Prints the errors subheading found on the help page of some words. This section should document any errors thrown by the word." } +{ $examples + { $markup-example { $errors "I/O errors, network errors, hardware errors... oh my!" } } +} ; + +HELP: $side-effects +{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } } +{ $description "Prints a heading followed by a list of input values or variables which are modified by the word being documented." } +{ $examples + { $markup-example + { { $values { "seq" "a mutable sequence" } } { $side-effects "seq" } } + } +} ; + +HELP: $notes +{ $values { "element" "a markup element" } } +{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ; + +HELP: $see +{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } } +{ $description "Prints the definition of " { $snippet "word" } " by calling " { $link see } "." } +{ $examples + { $markup-example { "Here is a word definition:" { $see reverse } } } +} ; + +HELP: $definition +{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } } +{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." } ; + +HELP: $curious +{ $values { "element" "a markup element" } } +{ $description "Prints a heading followed by a markup element." } +{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ; + +HELP: $references +{ $values { "element" "a markup element of the form " { $snippet "{ topic... }" } } } +{ $description "Prints a heading followed by a series of links." } +{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ; + +HELP: HELP: +{ $syntax "HELP: word content... ;" } +{ $values { "word" "a word" } { "content" "markup elements" } } +{ $description "Defines documentation for a word." } +{ $examples + { $code + ": foo 2 + ;" + "HELP: foo" + "{ $values { \"m\" \"an integer\" } { \"n\" \"an integer\" } }" + "{ $description \"Increments a value by 2.\" } ;" + "\\ foo help" + } +} ; + +HELP: ARTICLE: +{ $syntax "ARTICLE: topic title content... ;" } +{ $values { "topic" "an object" } { "title" "a string" } { "content" "markup elements" } } +{ $description "Defines a help article. String topic names are reserved for core documentation. Contributed modules should name articles by arrays, where the first element of an array identifies the module; for example, " { $snippet "{ \"httpd\" \"intro\" }" } "." } +{ $examples + { $code + "ARTICLE: \"example\" \"An example article\"" + "\"Hello world.\" ;" + } +} ; + +HELP: ABOUT: +{ $syntax "MAIN: article" } +{ $values { "article" "a help article" } } +{ $description "Defines the main documentation article for the current vocabulary." } ; + +HELP: vocab-help +{ $values { "vocab" "a vocabulary specifier" } { "help" "a help article" } } +{ $description "Outputs the main help article for a vocabulary. The main help article can be set with " { $link POSTPONE: ABOUT: } "." } ; + USE: help.lint diff --git a/extra/help/markup/markup-docs.factor b/extra/help/markup/markup-docs.factor deleted file mode 100644 index f6ef5f8408..0000000000 --- a/extra/help/markup/markup-docs.factor +++ /dev/null @@ -1,206 +0,0 @@ -USING: help.syntax help.stylesheet arrays -definitions io math prettyprint sequences ; -IN: help.markup - -ABOUT: "element-types" - -HELP: print-element -{ $values { "element" "a markup element" } } -{ $description "Prints a markup element to the " { $link stdio } " stream." } ; - -HELP: print-content -{ $values { "element" "a markup element" } } -{ $description "Prints a top-level markup element to the " { $link stdio } " stream." } ; - -HELP: simple-element -{ $class-description "Class of simple elements, which are just arrays of elements." } ; - -HELP: ($span) -{ $values { "quot" "a quotation" } } -{ $description "Prints an inline markup element." } ; - -HELP: ($block) -{ $values { "quot" "a quotation" } } -{ $description "Prints a block markup element with newlines before and after." } ; - -HELP: $heading -{ $values { "element" "a markup element" } } -{ $description "Prints a markup element, usually a string, as a block with the " { $link heading-style } "." } -{ $examples - { $markup-example { $heading "What remains to be discovered" } } -} ; - -HELP: $subheading -{ $values { "element" "a markup element of the form " { $snippet "{ title content }" } } } -{ $description "Prints a markup element, usually a string, as a block with the " { $link strong-style } "." } -{ $examples - { $markup-example { $subheading "Developers, developers, developers!" } } -} ; - -HELP: $code -{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } } -{ $description "Prints code examples, as seen in many help articles. The markup element must be an array of strings." } -{ $notes - "The code becomes clickable if the output stream supports it, and clicking it opens a listener window with the text inserted at the input prompt." - $nl - "If you want to show code along with sample output, use the " { $link $example } " element." -} -{ $examples - { $markup-example { $code "2 2 + ." } } -} ; - -HELP: $vocabulary -{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } } -{ $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ; - -HELP: $description -{ $values { "element" "a markup element" } } -{ $description "Prints the description subheading found on the help page of most words." } ; - -HELP: $contract -{ $values { "element" "a markup element" } } -{ $description "Prints a heading followed by a contract, found on the help page of generic words. Every generic word should document a contract which specifies method behavior that callers can rely upon, and implementations must obey." } -{ $examples - { $markup-example { $contract "Methods of this generic word must always crash." } } -} ; - -HELP: $examples -{ $values { "element" "a markup element" } } -{ $description "Prints a heading followed by some examples. Word documentation should include examples, at least if the usage of the word is not entirely obvious." } -{ $examples - { $markup-example { $examples { $example "2 2 + ." "4" } } } -} ; - -HELP: $example -{ $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } } -{ $description "Prints a clickable example with sample output. The markup element must be an array of strings. All but the last string are joined by newlines and taken as the input text, and the last string is the output. The example becomes clickable if the output stream supports it, and clicking it opens a listener window with the input text inserted at the input prompt." } -{ $examples - "The output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:" - { $markup-example { $unchecked-example "2 2 +" "4" } } - "However the following is right:" - { $markup-example { $example "2 2 + ." "4" } } - "Examples can incorporate a call to " { $link .s } " to show multiple output values; the convention is that you may assume the stack is empty before the example evaluates." -} ; - -HELP: $markup-example -{ $values { "element" "a markup element" } } -{ $description "Prints a clickable example showing the prettyprinted source text of " { $snippet "element" } " followed by rendered output. The example becomes clickable if the output stream supports it." } -{ $examples - { $markup-example { $markup-example { $emphasis "Hi" } } } -} ; - -HELP: $warning -{ $values { "element" "a markup element" } } -{ $description "Prints an element inset in a block styled as so to draw the reader's attention towards it." } -{ $examples - { $markup-example { $warning "Incorrect use of this product may cause serious injury or death." } } -} ; - -HELP: $link -{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } } -{ $description "Prints a link to a help article or word." } -{ $examples - { $markup-example { $link "dlists" } } - { $markup-example { $link + } } -} ; - -HELP: textual-list -{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } -{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." } -{ $examples - { $example "USE: help.markup" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } -} ; - -HELP: $links -{ $values { "topics" "a sequence of article names or words" } } -{ $description "Prints a series of links to help articles or word documentation." } -{ $notes "This markup element is used to implement " { $link $links } "." } -{ $examples - { $markup-example { $links + - * / } } -} ; - -HELP: $see-also -{ $values { "topics" "a sequence of article names or words" } } -{ $description "Prints a heading followed by a series of links." } -{ $examples - { $markup-example { $see-also "graphs" "dlists" } } -} ; - -{ $see-also $related related-words } related-words - -HELP: $table -{ $values { "element" "an array of arrays of markup elements" } } -{ $description "Prints a table given as an array of rows, where each row must have the same number of columns." } -{ $examples - { $markup-example - { $table - { "a" "b" "c" } - { "d" "e" "f" } - } - } -} ; - -HELP: $values -{ $values { "element" "an array of pairs of markup elements" } } -{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder can be an element of any form." } ; - -HELP: $list -{ $values { "element" "an array of markup elements" } } -{ $description "Prints a bulleted list of markup elements." } -{ $notes - "A common mistake is that if an item consists of more than just a string, it will be broken up as several items:" - { $markup-example - { $list - "First item" - "Second item " { $emphasis "with emphasis" } - } - } - "The fix is easy; just group the two markup elements making up the second item into one markup element:" - { $markup-example - { $list - "First item" - { "Second item " { $emphasis "with emphasis" } } - } - } -} ; - -HELP: $errors -{ $values { "element" "a markup element" } } -{ $description "Prints the errors subheading found on the help page of some words. This section should document any errors thrown by the word." } -{ $examples - { $markup-example { $errors "I/O errors, network errors, hardware errors... oh my!" } } -} ; - -HELP: $side-effects -{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } } -{ $description "Prints a heading followed by a list of input values or variables which are modified by the word being documented." } -{ $examples - { $markup-example - { { $values { "seq" "a mutable sequence" } } { $side-effects "seq" } } - } -} ; - -HELP: $notes -{ $values { "element" "a markup element" } } -{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ; - -HELP: $see -{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } } -{ $description "Prints the definition of " { $snippet "word" } " by calling " { $link see } "." } -{ $examples - { $markup-example { "Here is a word definition:" { $see reverse } } } -} ; - -HELP: $definition -{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } } -{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." } ; - -HELP: $curious -{ $values { "element" "a markup element" } } -{ $description "Prints a heading followed by a markup element." } -{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ; - -HELP: $references -{ $values { "element" "a markup element of the form " { $snippet "{ topic... }" } } } -{ $description "Prints a heading followed by a series of links." } -{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ; diff --git a/extra/help/syntax/syntax-docs.factor b/extra/help/syntax/syntax-docs.factor deleted file mode 100644 index 6aab791619..0000000000 --- a/extra/help/syntax/syntax-docs.factor +++ /dev/null @@ -1,35 +0,0 @@ -USING: help.markup help.syntax vocabs ; - -HELP: HELP: -{ $syntax "HELP: word content... ;" } -{ $values { "word" "a word" } { "content" "markup elements" } } -{ $description "Defines documentation for a word." } -{ $examples - { $code - ": foo 2 + ;" - "HELP: foo" - "{ $values { \"m\" \"an integer\" } { \"n\" \"an integer\" } }" - "{ $description \"Increments a value by 2.\" } ;" - "\\ foo help" - } -} ; - -HELP: ARTICLE: -{ $syntax "ARTICLE: topic title content... ;" } -{ $values { "topic" "an object" } { "title" "a string" } { "content" "markup elements" } } -{ $description "Defines a help article. String topic names are reserved for core documentation. Contributed modules should name articles by arrays, where the first element of an array identifies the module; for example, " { $snippet "{ \"httpd\" \"intro\" }" } "." } -{ $examples - { $code - "ARTICLE: \"example\" \"An example article\"" - "\"Hello world.\" ;" - } -} ; - -HELP: ABOUT: -{ $syntax "MAIN: article" } -{ $values { "article" "a help article" } } -{ $description "Defines the main documentation article for the current vocabulary." } ; - -HELP: vocab-help -{ $values { "vocab" "a vocabulary specifier" } { "help" "a help article" } } -{ $description "Outputs the main help article for a vocabulary. The main help article can be set with " { $link POSTPONE: ABOUT: } "." } ; diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor old mode 100644 new mode 100755 index cade859a5c..99f318eaf4 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax io.launcher quotations kernel ; +USING: help.markup help.syntax quotations kernel ; IN: io.launcher HELP: +command+ diff --git a/extra/math/vectors/vectors-docs.factor b/extra/math/vectors/vectors-docs.factor index 2005d99b44..fe33dd65e3 100755 --- a/extra/math/vectors/vectors-docs.factor +++ b/extra/math/vectors/vectors-docs.factor @@ -100,3 +100,7 @@ HELP: set-axis { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } } { $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." } { $examples { $example "USE: math.vectors" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; + +{ 2map v+ v- v* v/ } related-words + +{ 2reduce v. } related-words diff --git a/extra/qualified/qualified-docs.factor b/extra/qualified/qualified-docs.factor old mode 100644 new mode 100755 index 6356b4d310..36a503bec4 --- a/extra/qualified/qualified-docs.factor +++ b/extra/qualified/qualified-docs.factor @@ -1,4 +1,5 @@ -USING: qualified help.markup help.syntax ; +USING: help.markup help.syntax ; +IN: qualified HELP: QUALIFIED: { $syntax "QUALIFIED: vocab" } diff --git a/extra/shuffle/shuffle-docs.factor b/extra/shuffle/shuffle-docs.factor old mode 100644 new mode 100755 index fdbbd449ff..8f6ccc410a --- a/extra/shuffle/shuffle-docs.factor +++ b/extra/shuffle/shuffle-docs.factor @@ -1,83 +1,84 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup kernel sequences shuffle ; - -HELP: npick -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link dup } ", " -{ $link over } " and " { $link pick } " that can work " -"for any stack depth. The nth item down the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example "USE: shuffle" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } -} -{ $see-also dup over pick } ; - -HELP: ndup -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link dup } ", " -{ $link 2dup } " and " { $link 3dup } " that can work " -"for any number of items. The n topmost items on the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example "USE: shuffle" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } -} -{ $see-also dup 2dup 3dup } ; - -HELP: nnip -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link nip } " and " { $link 2nip } -" that can work " -"for any number of items." -} -{ $examples - { $example "USE: shuffle" "1 2 3 4 3 nnip .s" "4" } -} -{ $see-also nip 2nip } ; - -HELP: ndrop -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link drop } -" that can work " -"for any number of items." -} -{ $examples - { $example "USE: shuffle" "1 2 3 4 3 ndrop .s" "1" } -} -{ $see-also drop 2drop 3drop } ; - -HELP: nrot -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USE: shuffle" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } -} -{ $see-also rot -nrot } ; - -HELP: -nrot -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link -rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USE: shuffle" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } -} -{ $see-also rot nrot } ; - -ARTICLE: { "shuffle" "overview" } "Extra shuffle words" -"A number of stack shuffling words for those rare times when you " -"need to deal with tricky stack situations and can't refactor the " -"code to work around it." -{ $subsection ndup } -{ $subsection npick } -{ $subsection nrot } -{ $subsection -nrot } -{ $subsection nnip } -{ $subsection ndrop } ; - -IN: shuffle +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup kernel sequences ; +IN: shuffle + +HELP: npick +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link dup } ", " +{ $link over } " and " { $link pick } " that can work " +"for any stack depth. The nth item down the stack will be copied and " +"placed on the top of the stack." +} +{ $examples + { $example "USE: shuffle" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } +} +{ $see-also dup over pick } ; + +HELP: ndup +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link dup } ", " +{ $link 2dup } " and " { $link 3dup } " that can work " +"for any number of items. The n topmost items on the stack will be copied and " +"placed on the top of the stack." +} +{ $examples + { $example "USE: shuffle" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } +} +{ $see-also dup 2dup 3dup } ; + +HELP: nnip +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link nip } " and " { $link 2nip } +" that can work " +"for any number of items." +} +{ $examples + { $example "USE: shuffle" "1 2 3 4 3 nnip .s" "4" } +} +{ $see-also nip 2nip } ; + +HELP: ndrop +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link drop } +" that can work " +"for any number of items." +} +{ $examples + { $example "USE: shuffle" "1 2 3 4 3 ndrop .s" "1" } +} +{ $see-also drop 2drop 3drop } ; + +HELP: nrot +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USE: shuffle" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } +} +{ $see-also rot -nrot } ; + +HELP: -nrot +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link -rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USE: shuffle" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } +} +{ $see-also rot nrot } ; + +ARTICLE: { "shuffle" "overview" } "Extra shuffle words" +"A number of stack shuffling words for those rare times when you " +"need to deal with tricky stack situations and can't refactor the " +"code to work around it." +{ $subsection ndup } +{ $subsection npick } +{ $subsection nrot } +{ $subsection -nrot } +{ $subsection nnip } +{ $subsection ndrop } ; + +IN: shuffle ABOUT: { "shuffle" "overview" } \ No newline at end of file diff --git a/extra/ui/freetype/freetype-docs.factor b/extra/ui/freetype/freetype-docs.factor old mode 100644 new mode 100755 index 3ba6c0f7ed..f463a7c0e7 --- a/extra/ui/freetype/freetype-docs.factor +++ b/extra/ui/freetype/freetype-docs.factor @@ -1,5 +1,6 @@ -USING: help.syntax help.markup ui.freetype strings kernel -alien opengl quotations ui.render io.styles ; +USING: help.syntax help.markup strings kernel alien opengl +quotations ui.render io.styles freetype ; +IN: ui.freetype HELP: freetype { $values { "alien" alien } } @@ -14,8 +15,6 @@ HELP: init-freetype { $description "Initializes the FreeType library." } { $notes "Do not call this word if you are using the UI." } ; -USE: ui.freetype - HELP: font { $class-description "A font which has been loaded by FreeType. Font instances have the following slots:" { $list diff --git a/extra/ui/gadgets/books/books-docs.factor b/extra/ui/gadgets/books/books-docs.factor index 14528cef07..197ef7d4a2 100755 --- a/extra/ui/gadgets/books/books-docs.factor +++ b/extra/ui/gadgets/books/books-docs.factor @@ -1,5 +1,5 @@ -USING: ui.gadgets.books help.markup -help.syntax ui.gadgets models ; +USING: help.markup help.syntax ui.gadgets models ; +IN: ui.gadgets.books HELP: book { $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." diff --git a/extra/ui/gadgets/buttons/buttons-docs.factor b/extra/ui/gadgets/buttons/buttons-docs.factor old mode 100644 new mode 100755 index d398255bc4..02ddcc3d8a --- a/extra/ui/gadgets/buttons/buttons-docs.factor +++ b/extra/ui/gadgets/buttons/buttons-docs.factor @@ -1,6 +1,6 @@ -USING: ui.gadgets.buttons help.markup help.syntax ui.gadgets -ui.gadgets.labels ui.gadgets.menus ui.render kernel models -classes ; +USING: help.markup help.syntax ui.gadgets ui.gadgets.labels +ui.render kernel models classes ; +IN: ui.gadgets.buttons HELP: button { $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation." @@ -54,10 +54,6 @@ HELP: { $values { "target" object } { "toolbar" gadget } } { $description "Creates a row of " { $link } " gadgets invoking commands on " { $snippet "target" } ". The commands are taken from the " { $snippet "\"toolbar\"" } " command group of each class in " { $snippet "classes" } "." } ; -HELP: -{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } } -{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ; - ARTICLE: "ui.gadgets.buttons" "Button gadgets" "Buttons respond to mouse clicks by invoking a quotation." { $subsection button } diff --git a/extra/ui/gadgets/frames/frames-docs.factor b/extra/ui/gadgets/frames/frames-docs.factor old mode 100644 new mode 100755 index cdae5cb287..6005b35cb9 --- a/extra/ui/gadgets/frames/frames-docs.factor +++ b/extra/ui/gadgets/frames/frames-docs.factor @@ -1,6 +1,6 @@ -USING: help.syntax ui.gadgets kernel arrays quotations tuples -ui.gadgets.grids ui.gadgets.frames ; -IN: help.markup +USING: help.syntax help.markup ui.gadgets kernel arrays +quotations tuples ui.gadgets.grids ; +IN: ui.gadgets.frames : $ui-frame-constant ( element -- ) drop diff --git a/extra/ui/gadgets/gadgets-docs.factor b/extra/ui/gadgets/gadgets-docs.factor index fd06d02ec0..30f6a26d00 100755 --- a/extra/ui/gadgets/gadgets-docs.factor +++ b/extra/ui/gadgets/gadgets-docs.factor @@ -1,5 +1,6 @@ -USING: ui.gadgets help.markup help.syntax opengl kernel strings +USING: help.markup help.syntax opengl kernel strings tuples classes quotations models ; +IN: ui.gadgets HELP: rect { $class-description "A rectangle with the following slots:" diff --git a/extra/ui/gadgets/grid-lines/grid-lines-docs.factor b/extra/ui/gadgets/grid-lines/grid-lines-docs.factor old mode 100644 new mode 100755 index 2318ce0960..92f6846774 --- a/extra/ui/gadgets/grid-lines/grid-lines-docs.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines-docs.factor @@ -1,5 +1,6 @@ -USING: ui.gadgets help.markup help.syntax ui.gadgets.grid-lines -ui.gadgets.grids ui.render ; +USING: ui.gadgets help.markup help.syntax ui.gadgets.grids +ui.render ; +IN: ui.gadgets.grid-lines HELP: grid-lines { $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ; diff --git a/extra/ui/gadgets/grids/grids-docs.factor b/extra/ui/gadgets/grids/grids-docs.factor old mode 100644 new mode 100755 index a52c7af7d5..a3a65f633f --- a/extra/ui/gadgets/grids/grids-docs.factor +++ b/extra/ui/gadgets/grids/grids-docs.factor @@ -1,5 +1,5 @@ -USING: ui.gadgets help.markup help.syntax arrays -ui.gadgets.grids ; +USING: ui.gadgets help.markup help.syntax arrays ; +IN: ui.gadgets.grids HELP: grid { $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height." diff --git a/extra/ui/gadgets/incremental/incremental-docs.factor b/extra/ui/gadgets/incremental/incremental-docs.factor old mode 100644 new mode 100755 index ecd417dea6..f7129ebbff --- a/extra/ui/gadgets/incremental/incremental-docs.factor +++ b/extra/ui/gadgets/incremental/incremental-docs.factor @@ -1,5 +1,5 @@ -USING: ui.gadgets help.markup help.syntax -ui.gadgets.incremental ui.gadgets.packs ; +USING: ui.gadgets help.markup help.syntax ui.gadgets.packs ; +IN: ui.gadgets.incremental HELP: incremental { $class-description "An incremental layout gadget delegates to a " { $link pack } " and implements an optimization which the relayout operation after adding a child to be done in constant time." diff --git a/extra/ui/gadgets/menus/menus-docs.factor b/extra/ui/gadgets/menus/menus-docs.factor old mode 100644 new mode 100755 index a621acfb48..505eb2231f --- a/extra/ui/gadgets/menus/menus-docs.factor +++ b/extra/ui/gadgets/menus/menus-docs.factor @@ -1,5 +1,10 @@ -USING: ui.gadgets help.markup help.syntax ui.gadgets.menus -ui.gadgets.worlds ; +USING: ui.gadgets help.markup help.syntax ui.gadgets.worlds +kernel ; +IN: ui.gadgets.menus + +HELP: +{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } } +{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ; HELP: show-menu { $values { "gadget" gadget } { "owner" gadget } } diff --git a/extra/ui/gadgets/packs/packs-docs.factor b/extra/ui/gadgets/packs/packs-docs.factor old mode 100644 new mode 100755 index 8162e8e660..55404c0ece --- a/extra/ui/gadgets/packs/packs-docs.factor +++ b/extra/ui/gadgets/packs/packs-docs.factor @@ -1,5 +1,6 @@ -USING: ui.gadgets ui.gadgets.packs help.markup help.syntax -generic kernel tuples quotations ; +USING: ui.gadgets help.markup help.syntax generic kernel tuples +quotations ; +IN: ui.gadgets.packs HELP: pack { $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:" diff --git a/extra/ui/gadgets/presentations/presentations-docs.factor b/extra/ui/gadgets/presentations/presentations-docs.factor old mode 100644 new mode 100755 index f24fa3ac55..f226df5c2a --- a/extra/ui/gadgets/presentations/presentations-docs.factor +++ b/extra/ui/gadgets/presentations/presentations-docs.factor @@ -1,6 +1,6 @@ -USING: help.markup help.syntax -ui.gadgets.buttons ui.gadgets.menus models ui.operations -inspector kernel ui.gadgets.worlds ui.gadgets ; +USING: help.markup help.syntax ui.gadgets.buttons +ui.gadgets.menus models ui.operations inspector kernel +ui.gadgets.worlds ui.gadgets ; IN: ui.gadgets.presentations HELP: presentation diff --git a/extra/ui/gadgets/scrollers/scrollers-docs.factor b/extra/ui/gadgets/scrollers/scrollers-docs.factor old mode 100644 new mode 100755 index 6a0608d4bf..ee82339f33 --- a/extra/ui/gadgets/scrollers/scrollers-docs.factor +++ b/extra/ui/gadgets/scrollers/scrollers-docs.factor @@ -1,5 +1,5 @@ -USING: ui.gadgets help.markup help.syntax -ui.gadgets.viewports ui.gadgets.sliders ; +USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports +ui.gadgets.sliders ; IN: ui.gadgets.scrollers HELP: scroller diff --git a/extra/ui/gadgets/status-bar/status-bar-docs.factor b/extra/ui/gadgets/status-bar/status-bar-docs.factor old mode 100644 new mode 100755 index 40ee352890..3391e89c0f --- a/extra/ui/gadgets/status-bar/status-bar-docs.factor +++ b/extra/ui/gadgets/status-bar/status-bar-docs.factor @@ -1,5 +1,6 @@ -USING: ui.gadgets.status-bar ui.gadgets.presentations -help.markup help.syntax models ui.gadgets ui.gadgets.worlds ; +USING: ui.gadgets.presentations help.markup help.syntax models +ui.gadgets ui.gadgets.worlds ; +IN: ui.gadgets.status-bar HELP: { $values { "model" model } { "gadget" "a new " { $link gadget } } } diff --git a/extra/ui/gadgets/tracks/tracks-docs.factor b/extra/ui/gadgets/tracks/tracks-docs.factor old mode 100644 new mode 100755 index 8e077177e3..967e8a29a1 --- a/extra/ui/gadgets/tracks/tracks-docs.factor +++ b/extra/ui/gadgets/tracks/tracks-docs.factor @@ -1,5 +1,6 @@ -USING: ui.gadgets.tracks ui.gadgets.packs help.markup -help.syntax ui.gadgets arrays kernel quotations tuples ; +USING: ui.gadgets.packs help.markup help.syntax ui.gadgets +arrays kernel quotations tuples ; +IN: ui.gadgets.tracks HELP: track { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link } "." } ; diff --git a/extra/ui/gadgets/viewports/viewports-docs.factor b/extra/ui/gadgets/viewports/viewports-docs.factor index 3e1b8c00a5..a0d39912fc 100755 --- a/extra/ui/gadgets/viewports/viewports-docs.factor +++ b/extra/ui/gadgets/viewports/viewports-docs.factor @@ -1,5 +1,5 @@ -USING: ui.gadgets.viewports help.markup -help.syntax ui.gadgets models ; +USING: help.markup help.syntax ui.gadgets models ; +IN: ui.gadgets.viewports HELP: viewport { $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link } "." } ; diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor old mode 100644 new mode 100755 index 34da6da6b3..a47717329d --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -1,6 +1,6 @@ -USING: ui.gadgets.worlds ui.gadgets ui.render ui.gestures -ui.backend help.markup help.syntax models ui.freetype opengl -strings ui.gadgets.worlds ; +USING: ui.gadgets ui.render ui.gestures ui.backend help.markup +help.syntax models opengl strings ; +IN: ui.gadgets.worlds HELP: origin { $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ; @@ -40,7 +40,7 @@ HELP: world { { $link world-status } " - a " { $link model } " holding a string to be displayed in the world's status bar." } { { $link world-focus } " - the current owner of the keyboard focus in the world." } { { $link world-focused? } " - a boolean indicating if the native window containing the world has keyboard focus." } - { { $link world-fonts } " - a hashtable mapping " { $link font } " instances to vectors of " { $link sprite } " instances." } + { { $link world-fonts } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." } { { $link world-handle } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." } { { $link world-loc } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." } } diff --git a/extra/ui/tools/debugger/debugger-docs.factor b/extra/ui/tools/debugger/debugger-docs.factor old mode 100644 new mode 100755 index ec2a6151dc..b57dafaf49 --- a/extra/ui/tools/debugger/debugger-docs.factor +++ b/extra/ui/tools/debugger/debugger-docs.factor @@ -1,5 +1,6 @@ -USING: ui.tools.debugger ui.gadgets help.markup help.syntax -kernel quotations continuations debugger ui ; +USING: ui.gadgets help.markup help.syntax kernel quotations +continuations debugger ui ; +IN: ui.tools.debugger HELP: { $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "gadget" "a new " { $link gadget } } } diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/extra/ui/tools/deploy/deploy-docs.factor old mode 100644 new mode 100755 index 4898b651a1..293a391279 --- a/extra/ui/tools/deploy/deploy-docs.factor +++ b/extra/ui/tools/deploy/deploy-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax ui.tools.deploy ; +USING: help.markup help.syntax ; +IN: ui.tools.deploy HELP: deploy-tool { $values { "vocab" "a vocabulary specifier" } } diff --git a/extra/ui/tools/interactor/interactor-docs.factor b/extra/ui/tools/interactor/interactor-docs.factor index 78fb2d652e..338a9be85e 100755 --- a/extra/ui/tools/interactor/interactor-docs.factor +++ b/extra/ui/tools/interactor/interactor-docs.factor @@ -1,5 +1,6 @@ -USING: ui.tools.interactor ui.gadgets ui.gadgets.editors -listener io help.syntax help.markup ; +USING: ui.gadgets ui.gadgets.editors listener io help.syntax +help.markup ; +IN: ui.tools.interactor HELP: interactor { $class-description "An interactor is an " { $link editor } " intended to be used as the input component of a " { $link "ui-listener" } "." From 825601ccc78900071daf5eb14936ff5229365459 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jan 2008 20:37:13 -0400 Subject: [PATCH 74/82] More circularity fixes --- core/bootstrap/stage2.factor | 2 +- core/classes/mixin/mixin.factor | 12 +++- core/vocabs/loader/loader-tests.factor | 17 ------ core/vocabs/loader/test/e/e.factor | 1 - core/vocabs/loader/test/f/f-docs.factor | 4 -- core/vocabs/loader/test/f/f.factor | 1 - extra/bootstrap/help/help.factor | 3 + extra/bootstrap/tools/tools.factor | 2 +- extra/help/handbook/handbook.factor | 2 +- extra/help/help-docs.factor | 2 - extra/io/launcher/launcher.factor | 4 -- extra/io/mmap/mmap.factor | 7 +-- extra/io/unix/unix.factor | 2 + extra/io/windows/ce/ce.factor | 3 +- extra/io/windows/nt/files/files.factor | 6 +- extra/io/windows/nt/nt.factor | 2 + extra/io/windows/nt/sockets/sockets.factor | 2 +- extra/tools/deploy/backend/backend.factor | 59 ++++++++++++++++++++ extra/tools/deploy/deploy-docs.factor | 5 -- extra/tools/deploy/deploy.factor | 65 +--------------------- extra/tools/deploy/macosx/macosx.factor | 11 ++-- extra/tools/deploy/windows/windows.factor | 18 +++--- 22 files changed, 105 insertions(+), 125 deletions(-) delete mode 100644 core/vocabs/loader/test/e/e.factor delete mode 100644 core/vocabs/loader/test/f/f-docs.factor delete mode 100644 core/vocabs/loader/test/f/f.factor mode change 100644 => 100755 extra/io/unix/unix.factor mode change 100644 => 100755 extra/io/windows/nt/nt.factor create mode 100755 extra/tools/deploy/backend/backend.factor mode change 100644 => 100755 extra/tools/deploy/deploy-docs.factor diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3f0fac3882..5587f54c16 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -14,7 +14,7 @@ IN: bootstrap.stage2 vm file-name windows? [ >lower ".exe" ?tail drop ] when ".image" append "output-image" set-global - "math tools compiler help ui ui.tools io" "include" set-global + "math tools help compiler ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index a60a51c948..b56e3d771e 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.union words kernel sequences -definitions prettyprint.backend ; +definitions prettyprint.backend combinators ; IN: classes.mixin PREDICATE: union-class mixin-class "mixin" word-prop ; @@ -44,6 +44,14 @@ TUPLE: check-mixin-class mixin ; ! INSTANCE: declaration from a source file updates the mixin. TUPLE: mixin-instance loc class mixin ; +M: mixin-instance equal? + { + { [ over mixin-instance? not ] [ f ] } + { [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] } + { [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] } + { [ t ] [ t ] } + } cond 2nip ; + : ( class mixin -- definition ) { set-mixin-instance-class set-mixin-instance-mixin } mixin-instance construct ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 82e3187c75..1d20cb7370 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -136,21 +136,4 @@ forget-junk "xabbabbja" forget-vocab -"bootstrap.help" vocab [ - [ - "again" off - - [ "vocabs.loader.test.e" require ] catch drop - - [ 3 ] [ restarts get length ] unit-test - - [ ] [ - "again" get not restarts get length 3 = and [ - "again" on - :2 - ] when - ] unit-test - ] with-scope -] when - forget-junk diff --git a/core/vocabs/loader/test/e/e.factor b/core/vocabs/loader/test/e/e.factor deleted file mode 100644 index bf9ba22f5b..0000000000 --- a/core/vocabs/loader/test/e/e.factor +++ /dev/null @@ -1 +0,0 @@ -USE: vocabs.loader.test.f diff --git a/core/vocabs/loader/test/f/f-docs.factor b/core/vocabs/loader/test/f/f-docs.factor deleted file mode 100644 index 1beaa99ba2..0000000000 --- a/core/vocabs/loader/test/f/f-docs.factor +++ /dev/null @@ -1,4 +0,0 @@ -USE: vocabs.loader.test.e - -! a syntax error -123 iterate-next diff --git a/core/vocabs/loader/test/f/f.factor b/core/vocabs/loader/test/f/f.factor deleted file mode 100644 index 8b13789179..0000000000 --- a/core/vocabs/loader/test/f/f.factor +++ /dev/null @@ -1 +0,0 @@ - diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor index 13e9adf651..e88091105b 100755 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -4,6 +4,9 @@ parser vocabs.loader ; IN: bootstrap.help : load-help + "alien.syntax" require + "compiler" require + t load-help? set-global [ vocab ] load-vocab-hook [ diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index fab6a093ee..7b909ea1f6 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -4,7 +4,7 @@ USING: vocabs.loader sequences ; "bootstrap.image" "tools.annotations" "tools.crossref" - "tools.deploy" + ! "tools.deploy" "tools.memory" "tools.profiler" "tools.test" diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 772345a243..0fb6b72805 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -2,7 +2,7 @@ USING: help help.markup help.syntax help.topics namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io tools.browser generic math tools.profiler system ui strings sbufs vectors -byte-arrays bit-arrays float-arrays quotations ; +byte-arrays bit-arrays float-arrays quotations help.lint ; IN: help.handbook ARTICLE: "conventions" "Conventions" diff --git a/extra/help/help-docs.factor b/extra/help/help-docs.factor index 2be3f65c4b..fc795572fb 100755 --- a/extra/help/help-docs.factor +++ b/extra/help/help-docs.factor @@ -400,5 +400,3 @@ HELP: ABOUT: HELP: vocab-help { $values { "vocab" "a vocabulary specifier" } { "help" "a help article" } } { $description "Outputs the main help article for a vocabulary. The main help article can be set with " { $link POSTPONE: ABOUT: } "." } ; - -USE: help.lint diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 7de9d91bc7..806b56a092 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -56,7 +56,3 @@ HOOK: process-stream* io-backend ( desc -- stream ) : ( obj -- stream ) >descriptor process-stream* ; - -unix? [ "io.unix.launcher" require ] when -windows? [ "io.windows.launcher" require ] when -winnt? [ "io.windows.nt.launcher" require ] when diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index 37ae0617f8..26378a06aa 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: continuations io.backend kernel quotations sequences -system alien sequences.private combinators vocabs.loader ; +system alien sequences.private ; IN: io.mmap TUPLE: mapped-file length address handle closed? ; @@ -34,8 +34,3 @@ HOOK: (close-mapped-file) io-backend ( mmap -- ) >r r> [ keep ] curry [ close-mapped-file ] [ ] cleanup ; inline - -{ - { [ unix? ] [ "io.unix.mmap" ] } - { [ windows? ] [ "io.windows.mmap" ] } -} cond require diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor old mode 100644 new mode 100755 index 030b1185da..7114f388e0 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,8 @@ USE: io.unix.backend USE: io.unix.files USE: io.unix.sockets +USE: io.unix.launcher +USE: io.unix.mmap USE: io.backend USE: namespaces diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index 4c0237761e..ac5066e7ae 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -1,5 +1,6 @@ USING: io.backend io.windows io.windows.ce.backend -io.windows.ce.files io.windows.ce.sockets namespaces ; +io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher +namespaces ; IN: io.windows.ce T{ windows-ce-io } io-backend set-global diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 5eed39224c..375f35176c 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,6 +1,6 @@ -USING: continuations destructors io.buffers io.nonblocking io.windows -io.windows.nt io.windows.nt.backend kernel libc math -threads windows windows.kernel32 ; +USING: continuations destructors io.buffers io.nonblocking +io.windows io.windows.nt.backend kernel libc math threads +windows windows.kernel32 ; IN: io.windows.nt.files M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor old mode 100644 new mode 100755 index 7469410238..9ec97b33c6 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -4,6 +4,8 @@ USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files USE: io.windows.nt.sockets +USE: io.windows.nt.launcher +USE: io.windows.mmap USE: io.backend USE: namespaces diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 47ab7795b0..e86f070719 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types byte-arrays continuations destructors io.nonblocking io io.sockets io.sockets.impl namespaces -io.streams.duplex io.windows io.windows.nt io.windows.nt.backend +io.streams.duplex io.windows io.windows.nt.backend windows.winsock kernel libc math sequences threads tuples.lib ; IN: io.windows.nt.sockets diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor new file mode 100755 index 0000000000..b7b3da7411 --- /dev/null +++ b/extra/tools/deploy/backend/backend.factor @@ -0,0 +1,59 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces continuations.private kernel.private init +assocs kernel vocabs words sequences memory io system arrays +continuations math definitions mirrors splitting parser classes +inspector layouts vocabs.loader prettyprint.config prettyprint +debugger io.streams.c io.streams.duplex io.files io.backend +quotations io.launcher words.private tools.deploy.config +bootstrap.image ; +IN: tools.deploy.backend + +: boot-image-name ( -- string ) + "boot." my-arch ".image" 3append ; + +: stage1 ( -- ) + #! If stage1 image doesn't exist, create one. + boot-image-name resource-path exists? + [ my-arch make-image ] unless ; + +: (copy-lines) ( stream -- stream ) + dup stream-readln [ print flush (copy-lines) ] when* ; + +: copy-lines ( stream -- ) + [ (copy-lines) ] [ stream-close ] [ ] cleanup ; + +: ?append swap [ append ] [ drop ] if ; + +: profile-string ( config -- string ) + [ + "" + deploy-math? get " math" ?append + deploy-compiler? get " compiler" ?append + deploy-ui? get " ui" ?append + native-io? " io" ?append + ] bind ; + +: deploy-command-line ( vm image vocab config -- vm flags ) + [ + "-include=" swap profile-string append , + + "-deploy-vocab=" swap append , + + "-output-image=" swap append , + + "-no-stack-traces" , + + "-no-user-init" , + ] { } make ; + +: stage2 ( vm image vocab config -- ) + deploy-command-line + >r "-i=" boot-image-name append 2array r> append dup . + + dup duplex-stream-out stream-close + copy-lines ; + +SYMBOL: deploy-implementation + +HOOK: deploy* deploy-implementation ( vocab -- ) diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor old mode 100644 new mode 100755 index f6e9cb2882..b225236249 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -19,11 +19,6 @@ $nl ABOUT: "tools.deploy" -HELP: deploy* -{ $values { "vm" "a pathname string" } { "image" "a pathname string" } { "vocab" "a vocabulary specifier" } { "config" assoc } } -{ $description "Deploys " { $snippet "vocab" } ", which must have a " { $link POSTPONE: MAIN: } " hook, using the specified VM and configuration. The deployed image is saved as " { $snippet "image" } "." } -{ $notes "This is a low-level word and in most cases " { $link deploy } " should be called instead." } ; - HELP: deploy { $values { "vocab" "a vocabulary specifier" } } { $description "Deploys " { $snippet "vocab" } ", saving the deployed image as " { $snippet { $emphasis "vocab" } ".image" } "." } ; diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 7a3fbb8fdd..f12512f510 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -1,68 +1,9 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces continuations.private kernel.private init -assocs kernel vocabs words sequences memory io system arrays -continuations math definitions mirrors splitting parser classes -inspector layouts vocabs.loader prettyprint.config prettyprint -debugger io.streams.c io.streams.duplex io.files io.backend -quotations io.launcher words.private tools.deploy.config -bootstrap.image ; +USING: tools.deploy.backend system vocabs.loader kernel ; IN: tools.deploy -r "-i=" boot-image-name append 2array r> append dup . - - dup duplex-stream-out stream-close - copy-lines ; - -: ?append swap [ append ] [ drop ] if ; - -: profile-string ( config -- string ) - [ - "" - deploy-math? get " math" ?append - deploy-compiler? get " compiler" ?append - deploy-ui? get " ui" ?append - native-io? " io" ?append - ] bind ; - -: deploy-command-line ( vm image vocab config -- vm flags ) - [ - "-include=" swap profile-string append , - - "-deploy-vocab=" swap append , - - "-output-image=" swap append , - - "-no-stack-traces" , - - "-no-user-init" , - ] { } make ; - -PRIVATE> - -: deploy* ( vm image vocab config -- ) - stage1 deploy-command-line stage2 ; - -SYMBOL: deploy-implementation - -HOOK: deploy deploy-implementation ( vocab -- ) +: deploy ( vocab -- ) deploy* ; macosx? [ "tools.deploy.macosx" require ] when winnt? [ "tools.deploy.windows" require ] when diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 7624fbeb9c..e6f41c6923 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files io.launcher kernel namespaces sequences -system tools.deploy tools.deploy.config assocs hashtables -prettyprint io.unix.backend cocoa cocoa.plists +system tools.deploy.backend tools.deploy.config assocs +hashtables prettyprint io.unix.backend cocoa cocoa.plists cocoa.application cocoa.classes qualified ; QUALIFIED: unix IN: tools.deploy.macosx @@ -71,13 +71,14 @@ T{ macosx-deploy-implementation } deploy-implementation set-global over rot parent-directory -> selectFile:inFileViewerRootedAtPath: drop ; -M: macosx-deploy-implementation deploy ( vocab -- ) +M: macosx-deploy-implementation deploy* ( vocab -- ) + stage1 ".app deploy tool" assert.app "." resource-path cd dup deploy-config [ bundle-name rm [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep - namespace deploy* + namespace stage2 bundle-name show-in-finder ] bind ; diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 34580cf6f9..89dc0d8cc3 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files kernel namespaces sequences system -tools.deploy tools.deploy.config assocs hashtables prettyprint -windows.shell32 windows.user32 ; +tools.deploy.backend tools.deploy.config assocs hashtables +prettyprint windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-vm ( executable bundle-name -- vm ) @@ -33,11 +33,13 @@ TUPLE: windows-deploy-implementation ; T{ windows-deploy-implementation } deploy-implementation set-global -M: windows-deploy-implementation deploy +M: windows-deploy-implementation deploy* + stage1 "." resource-path cd dup deploy-config [ - [ deploy-name get create-exe-dir ] keep - [ deploy-name get image-name ] keep - namespace - deploy-name get open-in-explorer - ] bind deploy* ; + [ + [ deploy-name get create-exe-dir ] keep + [ deploy-name get image-name ] keep + deploy-name get + ] bind + ] keep stage2 open-in-explorer ; From 5f5270ae90264169db53bbd8028384b8f758f4bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jan 2008 22:06:01 -0400 Subject: [PATCH 75/82] Cleaning up mixins --- core/classes/classes-tests.factor | 4 +++- core/classes/classes.factor | 2 +- core/classes/mixin/mixin.factor | 10 +++++++--- core/definitions/definitions.factor | 14 +++++++------- 4 files changed, 18 insertions(+), 12 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index c88141fd76..35cbef42be 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -2,7 +2,7 @@ USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes io.streams.string classes.private classes.union classes.mixin classes.predicate -vectors definitions ; +vectors definitions source-files ; IN: temporary H{ } "s" set @@ -176,6 +176,8 @@ FORGET: forget-class-bug-2 DEFER: mixin-forget-test-g +[ "mixin-forget-test" forget-source ] with-compilation-unit + [ ] [ { "USING: sequences ;" diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 63abec56f8..cf73148040 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -263,7 +263,7 @@ PRIVATE> uncache-classes dupd (define-class) ] keep cache-classes - r> [ changed-class ] [ drop ] if ; + r> [ update-methods ] [ drop ] if ; GENERIC: class ( object -- class ) inline diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index b56e3d771e..05d74b64c3 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.union words kernel sequences -definitions prettyprint.backend combinators ; +definitions prettyprint.backend combinators arrays ; IN: classes.mixin PREDICATE: union-class mixin-class "mixin" word-prop ; @@ -52,6 +52,10 @@ M: mixin-instance equal? { [ t ] [ t ] } } cond 2nip ; +M: mixin-instance hashcode* + { mixin-instance-class mixin-instance-mixin } get-slots + 2array hashcode* ; + : ( class mixin -- definition ) { set-mixin-instance-class set-mixin-instance-mixin } mixin-instance construct ; @@ -71,5 +75,5 @@ M: mixin-instance definition drop f ; M: mixin-instance forget dup mixin-instance-class - swap mixin-instance-mixin - remove-mixin-instance ; + swap mixin-instance-mixin dup mixin-class? + [ remove-mixin-instance ] [ 2drop ] if ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 055d969e66..694ee0c6f6 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -47,7 +47,7 @@ M: object redefined* drop ; GENERIC: update-methods ( class -- ) SYMBOL: changed-words -SYMBOL: changed-classes +! SYMBOL: changed-classes SYMBOL: old-definitions SYMBOL: new-definitions @@ -94,19 +94,19 @@ TUPLE: no-compilation-unit word ; [ no-compilation-unit ] unless* set-at ; -: changed-class ( class -- ) - dup changed-classes get - [ no-compilation-unit ] unless* - set-at ; +! : changed-class ( class -- ) +! dup changed-classes get +! [ no-compilation-unit ] unless* +! set-at ; : with-compilation-unit ( quot -- ) [ H{ } clone changed-words set - H{ } clone changed-classes set + ! H{ } clone changed-classes set new-definitions set old-definitions set [ - changed-classes get keys [ update-methods ] each + ! changed-classes get keys [ update-methods ] each changed-words get keys recompile-hook get call ] [ ] cleanup ] with-scope ; inline From b40c064fc638e6ec5219eabf93545407450d86f2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jan 2008 22:06:51 -0400 Subject: [PATCH 76/82] Remove some dead code --- core/definitions/definitions.factor | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 694ee0c6f6..5d8e1262be 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -47,7 +47,6 @@ M: object redefined* drop ; GENERIC: update-methods ( class -- ) SYMBOL: changed-words -! SYMBOL: changed-classes SYMBOL: old-definitions SYMBOL: new-definitions @@ -94,19 +93,11 @@ TUPLE: no-compilation-unit word ; [ no-compilation-unit ] unless* set-at ; -! : changed-class ( class -- ) -! dup changed-classes get -! [ no-compilation-unit ] unless* -! set-at ; - : with-compilation-unit ( quot -- ) [ H{ } clone changed-words set - ! H{ } clone changed-classes set new-definitions set old-definitions set - [ - ! changed-classes get keys [ update-methods ] each - changed-words get keys recompile-hook get call - ] [ ] cleanup + [ changed-words get keys recompile-hook get call ] + [ ] cleanup ] with-scope ; inline From e84ad1f2babd77189259dd9fb7cb72504c967f43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jan 2008 22:07:13 -0400 Subject: [PATCH 77/82] Make tools.annotations:reset more robust --- extra/tools/annotations/annotations.factor | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 45826724ca..d8696b7129 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -5,12 +5,17 @@ prettyprint continuations effects definitions ; IN: tools.annotations : reset ( word -- ) - dup "unannotated-def" word-prop define ; + dup "unannotated-def" word-prop [ + [ + dup "unannotated-def" word-prop define + ] with-compilation-unit + ] [ drop ] if ; : annotate ( word quot -- ) - over dup word-def "unannotated-def" set-word-prop - [ >r dup word-def r> call define ] with-compilation-unit ; - inline + [ + over dup word-def "unannotated-def" set-word-prop + >r dup word-def r> call define + ] with-compilation-unit ; inline : entering ( str -- ) "/-- Entering: " write dup . From b61c41163bf11834611230b14c5b737bd0a5a2be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jan 2008 00:07:12 -0400 Subject: [PATCH 78/82] Inefficient, experimental multi-methods implementation --- extra/multi-methods/multi-methods.factor | 53 ++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100755 extra/multi-methods/multi-methods.factor diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor new file mode 100755 index 0000000000..bc84b47c8d --- /dev/null +++ b/extra/multi-methods/multi-methods.factor @@ -0,0 +1,53 @@ +USING: kernel math sequences vectors classes combinators +generic.standard arrays words combinators.lib assocs parser ; +IN: multi-methods + +: maximal-element ( seq quot -- n elt ) + dupd [ + swapd [ call 0 < ] 2curry subset empty? + ] 2curry find [ "Topological sort failed" throw ] unless* ; + inline + +: topological-sort ( seq quot -- newseq ) + >r >vector [ dup empty? not ] r> + [ dupd maximal-element >r over delete-nth r> ] curry + [ ] unfold nip ; inline + +: classes< ( seq1 seq2 -- -1/0/1 ) + [ + { + { [ 2dup eq? ] [ 0 ] } + { [ 2dup class< ] [ -1 ] } + { [ 2dup swap class< ] [ 1 ] } + { [ t ] [ 0 ] } + } cond 2nip + ] 2map [ zero? not ] find nip 0 or ; + +: multi-predicate ( classes -- quot ) + dup length [ + >r "predicate" word-prop r> + (picker) swap append + ] 2map [ && ] curry ; + +: multi-dispatch-quot ( methods -- quot ) + [ >r multi-predicate r> ] assoc-map + [ "No method" throw ] swap reverse alist>quot ; + +: sorted-methods ( word -- methods ) + "multi-methods" word-prop >alist + [ [ first ] 2apply classes< ] topological-sort ; + +: make-generic ( word -- ) + dup sorted-methods multi-dispatch-quot define ; + +: GENERIC: + CREATE + dup H{ } clone "multi-methods" set-word-prop + make-generic ; parsing + +: add-method ( quot classes word -- ) + [ "multi-methods" word-prop set-at ] keep make-generic ; + +: METHOD: + parse-definition unclip swap unclip swap spin + add-method ; parsing From ede3f4d97719a7f2736b8c9d9c96c41fb30236c8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jan 2008 11:22:26 -0400 Subject: [PATCH 79/82] Improved multi-methods --- extra/multi-methods/authors.txt | 1 + .../multi-methods/multi-methods-tests.factor | 83 +++++++++ extra/multi-methods/multi-methods.factor | 158 ++++++++++++++++-- extra/multi-methods/summary.txt | 1 + 4 files changed, 230 insertions(+), 13 deletions(-) create mode 100755 extra/multi-methods/authors.txt create mode 100755 extra/multi-methods/multi-methods-tests.factor create mode 100755 extra/multi-methods/summary.txt diff --git a/extra/multi-methods/authors.txt b/extra/multi-methods/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/multi-methods/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor new file mode 100755 index 0000000000..a3ee584f98 --- /dev/null +++ b/extra/multi-methods/multi-methods-tests.factor @@ -0,0 +1,83 @@ +IN: temporary +USING: multi-methods tools.test kernel math arrays sequences +prettyprint strings classes hashtables assocs namespaces ; + +[ { 1 2 3 4 5 6 } ] [ + { 6 4 5 1 3 2 } [ <=> ] topological-sort +] unit-test + +[ -1 ] [ + { fixnum array } { number sequence } classes< +] unit-test + +[ 0 ] [ + { number sequence } { number sequence } classes< +] unit-test + +[ 1 ] [ + { object object } { number sequence } classes< +] unit-test + +[ + { + { { object integer } [ 1 ] } + { { object object } [ 2 ] } + { { POSTPONE: f POSTPONE: f } [ 3 ] } + } +] [ + { + { { integer } [ 1 ] } + { { } [ 2 ] } + { { f f } [ 3 ] } + } congruify-methods +] unit-test + +GENERIC: first-test + +[ t ] [ \ first-test generic? ] unit-test + +MIXIN: thing + +TUPLE: paper ; INSTANCE: paper thing +TUPLE: scissors ; INSTANCE: scissors thing +TUPLE: rock ; INSTANCE: rock thing + +GENERIC: beats? + +METHOD: beats? { paper scissors } t ; +METHOD: beats? { scissors rock } t ; +METHOD: beats? { rock paper } t ; +METHOD: beats? { thing thing } f ; + +: play ( obj1 obj2 -- ? ) beats? 2nip ; + +[ { } 3 play ] unit-test-fails +[ t ] [ T{ paper } T{ scissors } play ] unit-test +[ f ] [ T{ scissors } T{ paper } play ] unit-test + +[ t ] [ { beats? paper scissors } method-spec? ] unit-test +[ ] [ { beats? paper scissors } see ] unit-test + +GENERIC: legacy-test + +M: integer legacy-test sq ; +M: string legacy-test " hey" append ; + +[ 25 ] [ 5 legacy-test ] unit-test +[ "hello hey" ] [ "hello" legacy-test ] unit-test + +SYMBOL: some-var + +HOOK: hook-test some-var + +[ t ] [ \ hook-test hook-generic? ] unit-test + +METHOD: hook-test { array array } reverse ; +METHOD: hook-test { array } class ; +METHOD: hook-test { hashtable number } assoc-size ; + +{ 1 2 3 } some-var set +[ { f t t } ] [ { t t f } hook-test ] unit-test +[ fixnum ] [ 3 hook-test ] unit-test +5.0 some-var set +[ 0 ] [ H{ } hook-test ] unit-test diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index bc84b47c8d..0c87f8f72b 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -1,7 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences vectors classes combinators -generic.standard arrays words combinators.lib assocs parser ; +arrays words assocs parser namespaces definitions +prettyprint prettyprint.backend quotations ; IN: multi-methods +TUPLE: method loc def ; + +: { set-method-def } \ method construct ; + : maximal-element ( seq quot -- n elt ) dupd [ swapd [ call 0 < ] 2curry subset empty? @@ -23,31 +30,156 @@ IN: multi-methods } cond 2nip ] 2map [ zero? not ] find nip 0 or ; +: picker ( n -- quot ) + { + { 0 [ [ dup ] ] } + { 1 [ [ over ] ] } + { 2 [ [ pick ] ] } + [ 1- picker [ >r ] swap [ r> swap ] 3append ] + } case ; + : multi-predicate ( classes -- quot ) dup length [ >r "predicate" word-prop r> - (picker) swap append - ] 2map [ && ] curry ; + picker swap [ not ] 3append [ f ] 2array + ] 2map [ t ] swap alist>quot ; + +: method-defs ( methods -- methods' ) + [ method-def ] assoc-map ; : multi-dispatch-quot ( methods -- quot ) [ >r multi-predicate r> ] assoc-map [ "No method" throw ] swap reverse alist>quot ; -: sorted-methods ( word -- methods ) - "multi-methods" word-prop >alist +: methods ( word -- alist ) + "multi-methods" word-prop >alist ; + +: congruify-methods ( alist -- alist' ) + dup empty? [ + dup [ first length ] map supremum [ + swap >r object pad-left [ \ f or ] map r> + ] curry assoc-map + ] unless ; + +: sorted-methods ( alist -- alist' ) [ [ first ] 2apply classes< ] topological-sort ; +GENERIC: perform-combination ( word combination -- quot ) + +TUPLE: standard-combination ; + +: standard-combination ( methods -- quot ) + congruify-methods sorted-methods multi-dispatch-quot ; + +M: standard-combination perform-combination + drop methods method-defs standard-combination ; + +TUPLE: hook-combination var ; + +M: hook-combination perform-combination + hook-combination-var [ get ] curry + swap methods method-defs [ [ drop ] swap append ] assoc-map + standard-combination append ; + : make-generic ( word -- ) - dup sorted-methods multi-dispatch-quot define ; + dup dup "multi-combination" word-prop perform-combination + define ; + +: init-methods ( word -- ) + dup "multi-methods" word-prop + H{ } assoc-like + "multi-methods" set-word-prop ; + +: define-generic ( word combination -- ) + dupd "multi-combination" set-word-prop + dup init-methods + make-generic ; + +: define-standard-generic ( word -- ) + T{ standard-combination } define-generic ; : GENERIC: - CREATE - dup H{ } clone "multi-methods" set-word-prop - make-generic ; parsing + CREATE define-standard-generic ; parsing -: add-method ( quot classes word -- ) - [ "multi-methods" word-prop set-at ] keep make-generic ; +: define-hook-generic ( word var -- ) + hook-combination construct-boa define-generic ; + +: HOOK: + CREATE scan-word define-hook-generic ; parsing + +: method ( classes word -- method ) + "multi-methods" word-prop at ; + +: with-methods ( word quot -- ) + over >r >r "multi-methods" word-prop + r> call r> make-generic ; inline + +: add-method ( method classes word -- ) + [ set-at ] with-methods ; + +: forget-method ( classes word -- ) + [ delete-at ] with-methods ; + +: parse-method ( -- method classes word method-spec ) + parse-definition 2 cut + over >r + >r first2 swap r> -rot + r> first2 swap add* >array ; : METHOD: - parse-definition unclip swap unclip swap spin - add-method ; parsing + location + >r parse-method >r add-method r> r> + remember-definition ; parsing + +! For compatibility +: M: + scan-word 1array scan-word parse-definition + -rot add-method ; parsing + +! Definition protocol. We qualify core generics here +USE: qualified +QUALIFIED: syntax + +PREDICATE: word generic + "multi-combination" word-prop >boolean ; + +PREDICATE: word standard-generic + "multi-combination" word-prop standard-combination? ; + +PREDICATE: word hook-generic + "multi-combination" word-prop hook-combination? ; + +syntax:M: standard-generic definer drop \ GENERIC: f ; + +syntax:M: standard-generic definition drop f ; + +syntax:M: hook-generic definer drop \ HOOK: f ; + +syntax:M: hook-generic definition drop f ; + +syntax:M: hook-generic synopsis* + dup seeing-word \ HOOK: pprint-word dup pprint-word + dup "multi-combination" word-prop + hook-combination-var pprint-word stack-effect. ; + +PREDICATE: array method-spec + unclip generic? >r [ class? ] all? r> and ; + +syntax:M: method-spec where + dup unclip method method-loc [ ] [ second where ] ?if ; + +syntax:M: method-spec set-where + unclip method set-method-loc ; + +syntax:M: method-spec definer + drop \ METHOD: \ ; ; + +syntax:M: method-spec definition + unclip method method-def ; + +syntax:M: method-spec synopsis* + dup definer drop pprint-word + unclip pprint* pprint* ; + +syntax:M: method-spec forget + unclip [ delete-at ] with-methods ; diff --git a/extra/multi-methods/summary.txt b/extra/multi-methods/summary.txt new file mode 100755 index 0000000000..ec8214bee7 --- /dev/null +++ b/extra/multi-methods/summary.txt @@ -0,0 +1 @@ +Experimental multiple dispatch implementation From 07e5441b14984a6ee9cbf78719ba7edf62cf98cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jan 2008 12:13:44 -0400 Subject: [PATCH 80/82] Definition protocol cleanup --- core/classes/mixin/mixin.factor | 7 +----- core/generic/standard/standard.factor | 4 ++++ core/prettyprint/prettyprint.factor | 27 ++++++++++++++--------- extra/help/definitions/definitions.factor | 4 ++-- extra/locals/locals.factor | 10 +++++---- 5 files changed, 29 insertions(+), 23 deletions(-) mode change 100644 => 100755 core/generic/standard/standard.factor diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 05d74b64c3..847cce30bf 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.union words kernel sequences -definitions prettyprint.backend combinators arrays ; +definitions combinators arrays ; IN: classes.mixin PREDICATE: union-class mixin-class "mixin" word-prop ; @@ -64,11 +64,6 @@ M: mixin-instance where mixin-instance-loc ; M: mixin-instance set-where set-mixin-instance-loc ; -M: mixin-instance synopsis* - \ INSTANCE: pprint-word - dup mixin-instance-class pprint-word - mixin-instance-mixin pprint-word ; - M: mixin-instance definer drop \ INSTANCE: f ; M: mixin-instance definition drop f ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor old mode 100644 new mode 100755 index 75385b1685..45ecf7a031 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -182,3 +182,7 @@ M: standard-combination dispatch# standard-combination-# ; M: hook-combination dispatch# drop 0 ; M: simple-generic definer drop \ GENERIC: f ; + +M: standard-generic definer drop \ GENERIC# f ; + +M: hook-generic definer drop \ HOOK: f ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index c0ce3b45bd..0fcc6edab9 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -146,39 +146,44 @@ GENERIC: see ( defspec -- ) : seeing-word ( word -- ) word-vocabulary pprinter-in set ; +: definer. ( defspec -- ) + definer drop pprint-word ; + : stack-effect. ( word -- ) dup parsing? over symbol? or not swap stack-effect and [ effect>string comment. ] when* ; -: word-synopsis ( word name -- ) +: word-synopsis ( word -- ) dup seeing-word - over definer drop pprint-word - pprint-word + dup definer. + dup pprint-word stack-effect. ; -M: word synopsis* - dup word-synopsis ; +M: word synopsis* word-synopsis ; -M: simple-generic synopsis* - dup word-synopsis ; +M: simple-generic synopsis* word-synopsis ; M: standard-generic synopsis* + dup definer. dup seeing-word - \ GENERIC# pprint-word dup pprint-word dup dispatch# pprint* stack-effect. ; M: hook-generic synopsis* + dup definer. dup seeing-word - \ HOOK: pprint-word dup pprint-word dup "combination" word-prop hook-combination-var pprint-word stack-effect. ; M: method-spec synopsis* - dup definer drop pprint-word - [ pprint-word ] each ; + dup definer. [ pprint-word ] each ; + +M: mixin-instance synopsis* + dup definer. + dup mixin-instance-class pprint-word + mixin-instance-mixin pprint-word ; M: pathname synopsis* pprint* ; diff --git a/extra/help/definitions/definitions.factor b/extra/help/definitions/definitions.factor index eee2bcd19c..559acf3919 100755 --- a/extra/help/definitions/definitions.factor +++ b/extra/help/definitions/definitions.factor @@ -17,7 +17,7 @@ M: link forget link-name remove-article ; M: link definition article-content ; M: link synopsis* - \ ARTICLE: pprint-word + dup definer. dup link-name pprint* article-title pprint* ; @@ -30,7 +30,7 @@ M: word-link set-where link-name swap "help-loc" set-word-prop ; M: word-link definition link-name "help" word-prop ; M: word-link synopsis* - \ HELP: pprint-word + dup definer. link-name dup pprint-word stack-effect. ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 688507be78..7ac36745f9 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -314,14 +314,16 @@ M: lambda-word definer drop \ :: \ ; ; M: lambda-word definition "lambda" word-prop lambda-body ; -: lambda-word-synopsis ( word prop definer -- ) - pick seeing-word pprint-word over pprint-word +: lambda-word-synopsis ( word prop -- ) + over definer. + over seeing-word + over pprint-word \ | pprint-word word-prop lambda-vars pprint-vars \ | pprint-word ; M: lambda-word synopsis* - "lambda" \ :: lambda-word-synopsis ; + "lambda" lambda-word-synopsis ; PREDICATE: macro lambda-macro "lambda-macro" word-prop >boolean ; @@ -332,6 +334,6 @@ M: lambda-macro definition "lambda-macro" word-prop lambda-body ; M: lambda-macro synopsis* - "lambda-macro" \ MACRO:: lambda-word-synopsis ; + "lambda-macro" lambda-word-synopsis ; PRIVATE> From cf4c13f55bc663e144864e796c886144b8068a01 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jan 2008 12:13:54 -0400 Subject: [PATCH 81/82] Improving multi-methods --- .../multi-methods/multi-methods-tests.factor | 5 +- extra/multi-methods/multi-methods.factor | 84 +++++++++++++------ 2 files changed, 64 insertions(+), 25 deletions(-) diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index a3ee584f98..d2af88d02a 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -1,6 +1,7 @@ IN: temporary USING: multi-methods tools.test kernel math arrays sequences -prettyprint strings classes hashtables assocs namespaces ; +prettyprint strings classes hashtables assocs namespaces +debugger continuations ; [ { 1 2 3 4 5 6 } ] [ { 6 4 5 1 3 2 } [ <=> ] topological-sort @@ -52,6 +53,8 @@ METHOD: beats? { thing thing } f ; : play ( obj1 obj2 -- ? ) beats? 2nip ; [ { } 3 play ] unit-test-fails +[ t ] [ error get no-method? ] unit-test +[ ] [ error get error. ] unit-test [ t ] [ T{ paper } T{ scissors } play ] unit-test [ f ] [ T{ scissors } T{ paper } play ] unit-test diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 0c87f8f72b..1f260d94eb 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences vectors classes combinators arrays words assocs parser namespaces definitions -prettyprint prettyprint.backend quotations ; +prettyprint prettyprint.backend quotations arrays.lib +debugger io ; IN: multi-methods TUPLE: method loc def ; @@ -38,47 +39,80 @@ TUPLE: method loc def ; [ 1- picker [ >r ] swap [ r> swap ] 3append ] } case ; +: (multi-predicate) ( class picker -- quot ) + swap "predicate" word-prop append ; + : multi-predicate ( classes -- quot ) - dup length [ - >r "predicate" word-prop r> - picker swap [ not ] 3append [ f ] 2array - ] 2map [ t ] swap alist>quot ; - -: method-defs ( methods -- methods' ) - [ method-def ] assoc-map ; - -: multi-dispatch-quot ( methods -- quot ) - [ >r multi-predicate r> ] assoc-map - [ "No method" throw ] swap reverse alist>quot ; + dup length + [ picker 2array ] 2map + [ drop object eq? not ] assoc-subset + dup empty? [ drop [ t ] ] [ + [ (multi-predicate) ] { } assoc>map + unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + ] if ; : methods ( word -- alist ) "multi-methods" word-prop >alist ; +: method-defs ( methods -- methods' ) + [ method-def ] assoc-map ; + +TUPLE: no-method arguments generic ; + +: no-method ( argument-count generic -- * ) + >r narray r> \ no-method construct-boa throw ; inline + +: argument-count ( methods -- n ) + dup assoc-empty? [ drop 0 ] [ + keys [ length ] map supremum + ] if ; + +: multi-dispatch-quot ( methods generic -- quot ) + >r + [ [ >r multi-predicate r> ] assoc-map ] keep argument-count + r> [ no-method ] 2curry + swap reverse alist>quot ; + : congruify-methods ( alist -- alist' ) - dup empty? [ - dup [ first length ] map supremum [ - swap >r object pad-left [ \ f or ] map r> - ] curry assoc-map - ] unless ; + dup argument-count [ + swap >r object pad-left [ \ f or ] map r> + ] curry assoc-map ; : sorted-methods ( alist -- alist' ) [ [ first ] 2apply classes< ] topological-sort ; +: niceify-method [ dup \ f eq? [ drop f ] when ] map ; + +M: no-method error. + "Type check error" print + nl + "Generic word " write dup no-method-generic pprint + " does not have a method applicable to inputs:" print + dup no-method-arguments short. + nl + "Inputs have signature:" print + dup no-method-arguments [ class ] map niceify-method . + nl + "Defined methods in topological order: " print + no-method-generic + methods congruify-methods sorted-methods keys + [ niceify-method ] map stack. ; + GENERIC: perform-combination ( word combination -- quot ) TUPLE: standard-combination ; -: standard-combination ( methods -- quot ) - congruify-methods sorted-methods multi-dispatch-quot ; +: standard-combination ( methods generic -- quot ) + >r congruify-methods sorted-methods r> multi-dispatch-quot ; M: standard-combination perform-combination - drop methods method-defs standard-combination ; + drop [ methods method-defs ] keep standard-combination ; TUPLE: hook-combination var ; M: hook-combination perform-combination - hook-combination-var [ get ] curry - swap methods method-defs [ [ drop ] swap append ] assoc-map + hook-combination-var [ get ] curry swap methods + [ method-defs [ [ drop ] swap append ] assoc-map ] keep standard-combination append ; : make-generic ( word -- ) @@ -158,7 +192,9 @@ syntax:M: hook-generic definer drop \ HOOK: f ; syntax:M: hook-generic definition drop f ; syntax:M: hook-generic synopsis* - dup seeing-word \ HOOK: pprint-word dup pprint-word + dup definer. + dup seeing-word + dup pprint-word dup "multi-combination" word-prop hook-combination-var pprint-word stack-effect. ; @@ -178,7 +214,7 @@ syntax:M: method-spec definition unclip method method-def ; syntax:M: method-spec synopsis* - dup definer drop pprint-word + dup definer. unclip pprint* pprint* ; syntax:M: method-spec forget From b4b59521c7fda256ca41acee891004050d241c6b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jan 2008 12:17:38 -0400 Subject: [PATCH 82/82] Get locals to load --- extra/locals/locals.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 7ac36745f9..dfe16dd4ec 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -1,14 +1,15 @@ -! Inspired by -! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs - +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences sequences.private assocs math inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables combinators.lib prettyprint.sections ; - IN: locals +! Inspired by +! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs + MACRO: with-locals ( form -- quot ) lambda-rewrite ; -: :: "lambda" (::) drop define-compound ; parsing +: :: "lambda" (::) drop define ; parsing : MACRO:: "lambda-macro" (::) (MACRO:) ; parsing @@ -306,7 +307,7 @@ M: wlet pprint* { wlet-body wlet-vars wlet-bindings } get-slots pprint-let \ ] pprint-word ; -PREDICATE: compound lambda-word +PREDICATE: word lambda-word "lambda" word-prop >boolean ; M: lambda-word definer drop \ :: \ ; ;