clean:
rm -f vm/*.o
+ rm -f libfactor.a
vm/resources.o:
windres vm/factor.rs vm/resources.o
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:"
-! 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?
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 ;
: <alien> ( address -- alien )
SYMBOL: libraries
-global [
- libraries [ H{ } assoc-like ] change
-] bind
+libraries global [ H{ } assoc-like ] change-at
TUPLE: library path abi dll ;
>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 )
[
>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 ;
: <primitive-type> ( getter setter width boxer unboxer -- type )
<c-type>
! 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 ;
: generate-callback ( node -- )
dup alien-callback-xt dup rot [
init-templates
- generate-profiler-prologue
%save-word-xt
%prologue-later
dup alien-stack-frame [
{ $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."
} }
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:"
! 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
: 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*
-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"
{ $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" } "." } ;
-{ <array> <quotation> <string> <sbuf> <vector> <byte-array> <bit-array> }
-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." } ;
-! 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 ;
: (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>
over bit-array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: bit-array sequence
+INSTANCE: bit-array simple-c-ptr
+INSTANCE: bit-array c-ptr
+! 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
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
-global [ { "compiler" } add-use ] bind
-
"-no-stack-traces" cli-args member? [
f compiled-stack-traces? set-global
- 0 set-profiler-prologues
] when
-! 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.
+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
+! significantly, because frequenly called words
+! which are also quick to compile are replaced by
+! compiled definitions as soon as possible.
{
roll -roll declare not
find-pair-next namestack*
bitand bitor bitxor bitnot
+} compile
+"." write flush
+
+{
+ 1+ 1- 2/ < <= > >= shift min
+} compile
+
+"." write flush
+
+{
+ new nth push pop peek
+} compile
- new nth push pop peek hashcode* = get set
+"." write flush
+{
+ hashcode* = get set
+} compile
+
+"." write flush
+
+{
. lines
+} compile
+"." write flush
+
+{
malloc free memcpy
-} [ compile ] each
+} compile
+
+[ compiled-usages recompile ] recompile-hook set-global
-[ recompile ] parse-hook set-global
+" done" print flush
--- /dev/null
+IN: temporary
+USING: bootstrap.image bootstrap.image.private
+tools.test.inference ;
+
+\ ' must-infer
+\ write-image must-infer
-! 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
: 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
! JIT parameters
SYMBOL: jit-code-format
-SYMBOL: jit-setup
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-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
SYMBOL: jit-return
+SYMBOL: jit-profiling
+
+! Default definition for undefined words
+SYMBOL: undefined-quot
: userenv-offset ( symbol -- n )
{
{ 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 }
- { 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 }
- { jit-return 37 }
+ { jit-prolog 23 }
+ { jit-primitive-word 24 }
+ { jit-primitive 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 }
+ { jit-profiling 35 }
+ { undefined-quot 37 }
} at header-size + ;
: emit ( cell -- ) image get push ;
: 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.
#! 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
0 , ! count
0 , ! xt
0 , ! code
+ 0 , ! profiling
] { } make
\ word type-number object tag-number
[ emit-seq ] emit-object
: 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-setup
jit-prolog
- jit-word-primitive-jump
- jit-word-primitive-call
+ jit-primitive-word
+ jit-primitive
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
jit-return
+ jit-profiling
+ undefined-quot
} [ emit-userenv ] each ;
: fixup-header ( -- )
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
: make-image ( arch -- )
[
- parse-hook off
prepare-image
begin-image
"resource:/core/bootstrap/stage1.factor" run-file
load-help? off
crossref off
-changed-words off
! Bring up a bare cross-compiling vocabulary.
"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
H{ } clone class<map set
H{ } clone update-map set
-: 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" }
- { "<ratio>" "math.private" }
- { "string>float" "math.private" }
- { "float>string" "math.private" }
- { "float>bits" "math" }
- { "double>bits" "math" }
- { "bits>float" "math" }
- { "bits>double" "math" }
- { "<complex>" "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" }
- { "<word>" "words" }
- { "update-xt" "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" }
- { "add-compiled-block" "generator" }
- { "dlopen" "alien" }
- { "dlsym" "alien" }
- { "dlclose" "alien" }
- { "<byte-array>" "byte-arrays" }
- { "<bit-array>" "bit-arrays" }
- { "<displaced-alien>" "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" }
- { "<array>" "arrays" }
- { "begin-scan" "memory" }
- { "next-object" "memory" }
- { "end-scan" "memory" }
- { "size" "memory" }
- { "die" "kernel" }
- { "finalize-compile" "generator" }
- { "fopen" "io.streams.c" }
- { "fgetc" "io.streams.c" }
- { "fread" "io.streams.c" }
- { "fwrite" "io.streams.c" }
- { "fflush" "io.streams.c" }
- { "fclose" "io.streams.c" }
- { "<wrapper>" "kernel" }
- { "(clone)" "kernel" }
- { "array>vector" "vectors.private" }
- { "<string>" "strings" }
- { "(>tuple)" "tuples.private" }
- { "array>quotation" "quotations.private" }
- { "quotation-xt" "quotations" }
- { "<tuple>" "tuples.private" }
- { "tuple>array" "tuples" }
- { "profiling" "tools.profiler.private" }
- { "become" "kernel.private" }
- { "(sleep)" "threads.private" }
- { "<float-array>" "float-arrays" }
- { "curry" "kernel" }
- { "<tuple-boa>" "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
{
{
{ "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
{ "set-word-vocabulary" "words" }
}
{
- { "object" "kernel" }
+ { "quotation" "quotations" }
"def"
4
{ "word-def" "words" }
"tombstone" "hashtables.private" lookup t
2array >tuple 1quotation define-inline
+! Primitive words
+: make-primitive ( word vocab n -- )
+ >r create dup reset-word r> [ do-primitive ] curry [ ] like 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" }
+ { "<ratio>" "math.private" }
+ { "string>float" "math.private" }
+ { "float>string" "math.private" }
+ { "float>bits" "math" }
+ { "double>bits" "math" }
+ { "bits>float" "math" }
+ { "bits>double" "math" }
+ { "<complex>" "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" }
+ { "<word>" "words.private" }
+ { "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-array>" "byte-arrays" }
+ { "<bit-array>" "bit-arrays" }
+ { "<displaced-alien>" "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" }
+ { "<array>" "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" }
+ { "<wrapper>" "kernel" }
+ { "(clone)" "kernel" }
+ { "array>vector" "vectors.private" }
+ { "<string>" "strings" }
+ { "(>tuple)" "tuples.private" }
+ { "array>quotation" "quotations.private" }
+ { "quotation-xt" "quotations" }
+ { "<tuple>" "tuples.private" }
+ { "tuple>array" "tuples" }
+ { "profiling" "tools.profiler.private" }
+ { "become" "kernel.private" }
+ { "(sleep)" "threads.private" }
+ { "<float-array>" "float-arrays" }
+ { "curry" "kernel" }
+ { "<tuple-boa>" "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" }
+ { "(os-envs)" "system" }
+}
+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
"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
-
- [ [ hashtable? ] instances [ rehash ] each ] %
+ [
+ ! Rehash hashtables, since bootstrap.image creates them
+ ! using the host image's hashing algorithms
+ [ hashtable? ] instances [ rehash ] each
- \ boot ,
+ boot
+ ] %
"math.integers" require
"math.floats" require
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
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 help compiler ui ui.tools io" "include" set-global
"" "exclude" set-global
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
] [
"listener" require
"none" require
- "listener" use+
] if
[
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each
- ] no-parse-hook
-
- init-io
- init-stdio
- changed-words get clear-assoc
+ run-bootstrap-init
- "compile-errors" "generator" lookup [
- f swap set-global
- ] when*
+ "Compiling remaining words..." print
- run-bootstrap-init
+ all-words [ compiled? not ] subset recompile-hook get call
+ ] with-compiler-errors
f error set-global
f error-continuation set-global
] 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
"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
"TUPLE:"
"T{"
"UNION:"
- "USE-IF:"
"USE:"
"USING:"
"V{"
"{"
"}"
"CS{"
+ "<<"
+ ">>"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol
-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"
-! 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 ;
over byte-array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: byte-array sequence
+INSTANCE: byte-array simple-c-ptr
+INSTANCE: byte-array c-ptr
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" }
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 source-files ;
IN: temporary
H{ } "s" set
[ 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
[ 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
[ 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
[ 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
[ 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
[ mx1 ] [ array integer class-or ] unit-test
-\ mx1 forget
+[ \ mx1 forget ] with-compilation-unit
[ f ] [ array integer class-or mx1 = ] unit-test
[ 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 ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
FORGET: forget-class-bug-2
[ t ] [ integer dll class-or interned? ] unit-test
+
+DEFER: mixin-forget-test-g
+
+[ "mixin-forget-test" forget-source ] with-compilation-unit
+
+[ ] [
+ {
+ "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 <string-reader> "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 <string-reader> "mixin-forget-test"
+ parse-stream drop
+] unit-test
+
+[ { } mixin-forget-test-g ] unit-test-fails
+[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
: predicate-effect 1 { "?" } <effect> ;
-PREDICATE: compound predicate
- "predicating" word-prop >boolean ;
+PREDICATE: word predicate "predicating" word-prop >boolean ;
: define-predicate ( class predicate quot -- )
over [
: uncache-classes ( assoc -- )
[ drop uncache-class ] assoc-each ;
-GENERIC: update-methods ( class -- )
-
PRIVATE>
: define-class-props ( members superclass metaclass -- assoc )
: (define-class) ( word props -- )
over reset-class
+ over reset-generic
+ 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 -- )
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax help words definitions classes ;
IN: classes.mixin
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"
-! 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 ;
+USING: classes classes.union words kernel sequences
+definitions combinators arrays ;
IN: classes.mixin
PREDICATE: union-class mixin-class "mixin" word-prop ;
{ } 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 ;
+
+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 ;
+
+M: mixin-instance hashcode*
+ { mixin-instance-class mixin-instance-mixin } get-slots
+ 2array hashcode* ;
+
+: <mixin-instance> ( 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 definer drop \ INSTANCE: f ;
+
+M: mixin-instance definition drop f ;
+
+M: mixin-instance forget
+ dup mixin-instance-class
+ swap mixin-instance-mixin dup mixin-class?
+ [ remove-mixin-instance ] [ 2drop ] if ;
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"
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
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"
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
next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( assoc initial quot -- buckets )
- swap rot [ length <buckets> ] keep
+ spin [ length <buckets> ] keep
[ >r 2dup r> dup first roll call (distribute-buckets) ] each
nip ; inline
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 }
-"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 }
-"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:"
-{ $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 }
-"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-all }
+"Removing a word's optimized definition:"
+{ $subsection decompile }
+"The optimizing compiler can also compile and call a single quotation:"
+{ $subsection compile-call } ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
{ "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." }
-{ $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." } ;
-
-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."
-$nl
-"The compiler remembers which words failed to compile 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 "all-words forget-errors" }
-"Subsequent invocations of the compiler will consider all words for compilation." } ;
+{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
-HELP: compile-batch
+HELP: recompile
{ $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 } "." } ;
-
-{ :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." } ;
+{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
-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-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." } ;
-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
-{ $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
+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 } }
-{ $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." } ;
-! 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 continuations
-vocabs assocs alien.compiler ;
+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
-M: object inference-error-major? drop t ;
+SYMBOL: compiled-crossref
-: compile-error ( word error -- )
- batch-mode get [
- 2array compile-errors get push
- ] [
- "quiet" get [ drop ] [ print-error flush ] if drop
- ] if ;
+compiled-crossref global [ H{ } assoc-like ] change-at
-: begin-batch ( seq -- )
- batch-mode on
- "quiet" get [ drop ] [
- [ "Compiling " % length # " words..." % ] "" make
- print flush
- ] if
- 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 ( -- )
- batch-mode off
- "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 ;
-
-: compile ( word -- )
- H{ } clone [
- compiled-xts [ (compile) ] with-variable
- ] keep >alist finalize-compile ;
+: compiled-xref ( word dependencies -- )
+ 2dup "compiled-uses" set-word-prop
+ compiled-crossref get add-vertex ;
-: 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 ( seq -- )
- dup empty? [
- drop
- ] [
- dup begin-batch
- dup forget-errors
- [ try-compile ] each
- end-batch
- ] if ;
+: compiled-unxref ( word -- )
+ dup "compiled-uses" word-prop
+ compiled-crossref get remove-vertex ;
+
+: 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 sensitive?
+ [ at namespace swap update ] [ 2drop ] if
+ ] curry each
+ ] H{ } make-assoc keys ;
-: compile-vocabs ( seq -- ) [ words ] map concat compile-batch ;
+: ripple-up ( word -- )
+ compiled-usage [ queue-compile ] each ;
-: compile-all ( -- ) vocabs compile-vocabs ;
+: save-effect ( word effect -- )
+ over "compiled-uses" word-prop [
+ 2dup swap "compiled-effect" word-prop =
+ [ over ripple-up ] unless
+ ] when
+ "compiled-effect" set-word-prop ;
-: compile-quot ( quot -- word ) define-temp dup compile ;
+: finish-compile ( word effect dependencies -- )
+ >r dupd save-effect r> over compiled-unxref compiled-xref ;
-: compile-1 ( quot -- ) compile-quot execute ;
+: compile-succeeded ( word -- effect dependencies )
+ [
+ dup word-dataflow >r swap dup r> optimize generate
+ ] computing-dependencies ;
-: recompile ( -- )
- changed-words get [
- dup keys compile-batch clear-assoc
- ] when* ;
+: 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 ;
+
+: compile-loop ( assoc -- )
+ dup assoc-empty? [ drop ] [
+ dup delete-any (compile)
+ yield
+ compile-loop
+ ] if ;
+
+: recompile ( words -- )
+ [
+ H{ } clone compile-queue set
+ H{ } clone compiled set
+ [ queue-compile ] each
+ compile-queue get compile-loop
+ compiled get >alist modify-code-heap
+ ] with-scope ; inline
+
+: compile ( words -- )
+ [ compiled? not ] subset recompile ;
+
+: compile-call ( quot -- )
+ H{ } clone changed-words
+ [ define-temp dup 1array compile ] with-variable
+ execute ;
: recompile-all ( -- )
- all-words [ changed-word ] each recompile ;
+ [ all-words recompile ] with-compiler-errors ;
+
+: decompile ( word -- )
+ f 2array 1array modify-code-heap ;
--- /dev/null
+! 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 ;
--- /dev/null
+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." } ;
--- /dev/null
+! 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
"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
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
-
-[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-1 ] 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
+[ 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-call ] 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
[
] { } 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
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
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond
- ] compile-1
+ ] compile-call
] unit-test
[ "odd" ] [
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond
- ] compile-1
+ ] compile-call
] unit-test
[ "neither" ] [
{ [ dup alien? ] [ drop "alien" ] }
{ [ t ] [ drop "neither" ] }
} cond
- ] compile-1
+ ] compile-call
] unit-test
[ 3 ] [
{ [ dup fixnum? ] [ ] }
{ [ t ] [ drop t ] }
} cond
- ] compile-1
+ ] compile-call
] unit-test
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 ] [ { 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 [ 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-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
-
-[ 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
-
-[ "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
-
-[ ] [ [ 0 getenv ] compile-1 drop ] unit-test
-[ ] [ 1 getenv [ 1 setenv ] compile-1 ] 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
-
-[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] 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-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-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-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 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
-
-[ 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
-
-[ 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
-
-[ 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 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
-
-[ 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
-
-[ 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
-
-[ 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 ] [ 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
-
-[ -1 ] [ 0 [ fixnum-bitnot ] compile-1 ] unit-test
-[ -1 ] [ [ 0 fixnum-bitnot ] 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-1 ] 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
-
-[ 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+fast ] compile-1 ] unit-test
-[ 4 ] [ 1 [ 3 fixnum+fast ] compile-1 ] unit-test
-[ 4 ] [ [ 1 3 fixnum+fast ] compile-1 ] unit-test
-
-[ 30001 ] [ 1 [ 30000 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-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-1 ] 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
-
-[ 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
-
-[ 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
-
-[ 2 ] [ 8 -2 [ fixnum-shift ] compile-1 ] unit-test
-[ 2 ] [ 8 [ -2 fixnum-shift ] compile-1 ] 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
-
-[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-1 ] unit-test
-[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-1 ] 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
-
-[ 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
-
-[ 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
-
-[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test
-
-[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test
-
-[ t ] [ f [ f eq? ] compile-1 ] unit-test
+[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] 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-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-call drop ] unit-test
+[ ] [ 1 getenv [ 1 setenv ] compile-call ] 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-call ] 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-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-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-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-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-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-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-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-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-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-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-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-call ] unit-test
+[ -1 ] [ [ 0 fixnum-bitnot ] 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
+[ -3 ] [ [ -13 10 fixnum-mod ] compile-call ] 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-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-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-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*fast ] 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
+[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] 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-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-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-call ] unit-test
+[ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] 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-call ] unit-test
+[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] 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-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-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-call ] unit-test
+
+[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] 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 <array> 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
-
- [ 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
+ [ 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-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
[ ] [ 10000 [ test-fixnum* ] times ] unit-test
: compiled-fixnum>bignum fixnum>bignum ;
-\ compiled-fixnum>bignum compile
: test-fixnum>bignum
(random) >fixnum
[ ] [ 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
[ 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 <array> ] compile-1
+ [ 3 1 <array> ] compile-call
] unit-test
[ B{ 0 0 0 } ] [
- [ 3 <byte-array> ] compile-1
+ [ 3 <byte-array> ] compile-call
] unit-test
[ 500 ] [
- [ 500 <byte-array> length ] compile-1
+ [ 500 <byte-array> length ] compile-call
] unit-test
[ 1 2 ] [
- 1 2 [ <complex> ] compile-1 dup real swap imaginary
+ 1 2 [ <complex> ] compile-call
+ dup real-part swap imaginary-part
] unit-test
[ 1 2 ] [
- 1 2 [ <ratio> ] compile-1 dup numerator swap denominator
+ 1 2 [ <ratio> ] compile-call dup numerator swap denominator
] unit-test
-[ \ + ] [ \ + [ <wrapper> ] compile-1 ] unit-test
+[ \ + ] [ \ + [ <wrapper> ] 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 <byte-array> ] compile-1
+ [ 5 <byte-array> ] 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
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
"s" get [
- [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test
- [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
[ ] [ "s" get free ] unit-test
] when
-[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-1 *void* ] unit-test
-[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-1 *void* ] unit-test
-[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-1 *void* ] unit-test
+[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
+[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
+[ f ] [ f [ { POSTPONE: f } declare <void*> ] 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 <char> [ { byte-array } declare *char ] compile-1 ] unit-test
-[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-1 ] unit-test
+[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
+[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
-[ -100 ] [ -100 \ <char> xword-def compile-1 *char ] unit-test
-[ 156 ] [ -100 \ <uchar> xword-def compile-1 *uchar ] unit-test
+[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
+[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
-[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-1 ] unit-test
-[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-1 ] unit-test
+[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
+[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
-[ -1000 ] [ -1000 \ <short> xword-def compile-1 *short ] unit-test
-[ 64536 ] [ -1000 \ <ushort> xword-def compile-1 *ushort ] unit-test
+[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
+[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
-[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-1 ] unit-test
-[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-1 ] unit-test
+[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
+[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
-[ -100000 ] [ -100000 \ <int> xword-def compile-1 *int ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> xword-def compile-1 *uint ] unit-test
+[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
+[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
[ t ] [ pi pi <double> *double = ] unit-test
-[ t ] [ pi <double> [ { byte-array } declare *double ] compile-1 pi = ] unit-test
+[ t ] [ pi <double> [ { byte-array } declare *double ] compile-call pi = ] unit-test
! Silly
-[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - -0.001 0.001 between? ] unit-test
-[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - -0.001 0.001 between? ] unit-test
+[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
+[ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
-[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test
+[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
[ 4 ] [
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
{ alien } declare 1 alien-unsigned-1
- ] compile-1
+ ] compile-call
] unit-test
[
- B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-1
+ B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] unit-test-fails
[
- B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-1
+ B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
] unit-test-fails
[
[
{ [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
] keep 2 fixnum+fast
- ] compile-1
+ ] compile-call
] unit-test
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 } } ] [
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
-[ ] [ \ xyz compile ] unit-test
+[ t ] [ \ xyz compiled? ] unit-test
! Test predicate inlining
: pred-test-1
! 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
! regression
GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ;
-[ ] [ \ breakage compile ] unit-test
+[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] unit-test-fails
! regression
[ 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
! 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 ;
] unit-test
! compiling <tuple> with a non-literal class failed
-[ t ] [ [ <tuple> ] compile-quot word? ] unit-test
+: <tuple>-regression <tuple> ;
-GENERIC: foozul
+[ t ] [ \ <tuple>-regression compiled? ] unit-test
+
+GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
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-1 ] unit-test
-[ -5 ] [ 5 [ 0 swap - ] compile-1 ] unit-test
-[ 0 ] [ 5 [ dup - ] compile-1 ] 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
-
-[ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test
-[ 0 ] [ 5 [ 1 rem ] compile-1 ] 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 [ 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 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
-
-[ 0 ] [ 5 [ 0 swap shift ] compile-1 ] unit-test
-[ 5 ] [ 5 [ 0 shift ] compile-1 ] 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
-
-[ 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
+[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap + ] compile-call ] 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-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-call ] unit-test
+[ 0 ] [ 5 [ 1 rem ] compile-call ] 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-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-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-call ] unit-test
+[ 5 ] [ 5 [ 0 shift ] compile-call ] 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-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 [ <array> 0 + detect-number ] compile-1 ] unit-test-fails
+[ 10 f [ <array> 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
[ 10 ] [
10 20 >vector <flat-slice>
- [ [ - ] swap old-binsearch ] compile-1 2nip
+ [ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
! Regression
T{ silly-tuple f 1 2 }
[
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
- ] compile-1
+ ] 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
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
-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 ] 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
+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
+
+[ ] [ "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
+
+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
+
+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 ) <array> >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
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
+
+! Regression
+
+[ ] [ [ callstack ] compile-call drop ] unit-test
: foo 3 throw 7 ;
: bar foo 4 ;
: baz bar 5 ;
-\ baz compile
[ 3 ] [ [ baz ] catch ] unit-test
[ t ] [
symbolic-stack-trace
] unit-test
: bleh [ 3 + ] map [ 0 > ] subset ;
-\ bleh compile
: stack-trace-contains? symbolic-stack-trace memq? ;
] unit-test
: quux [ t [ "hi" throw ] when ] times ;
-\ quux compile
[ t ] [
[ 10 quux ] catch drop
IN: temporary
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
-words kernel math effects ;
+words kernel math effects definitions ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
[
[ ] [ init-templates ] unit-test
- [ ] [ init-generator ] unit-test
+ [ ] [ \ + init-generator ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
! Test template picking strategy
SYMBOL: template-chosen
-: template-test ( a b -- c ) + ;
+: template-test ( a b -- c d ) ;
\ template-test {
{
1 template-chosen get push
] H{
{ +input+ { { f "obj" } { [ ] "n" } } }
- { +output+ { "obj" } }
+ { +output+ { "obj" "obj" } }
}
}
{
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
{ { 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" } ]
! 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!
-[ 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 ;
[ 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
[ ] [
[
[ 200 dup [ 200 3array ] curry map drop ] times
- ] compile-quot drop
+ ] [ define-temp ] with-compilation-unit drop
] 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
[ ] [
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
[ 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
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 } ] [
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
"!!! 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
[ 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
+ [ 1 ] [ error-counter get ] unit-test
+] with-scope
! 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
>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 )
[
byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture
-: set-profiler-prologues ( n -- )
- 39 setenv ;
-
SYMBOL: compiler-backend
! A pseudo-register class for parameters spilled on the stack
: %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 ( -- )
! 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 -- )
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 ;
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
;
"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
t have-BLX? set-global
] when
-7 cells set-profiler-prologues
+7 cells profiler-prologues set-global
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
;
"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" } } }
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? ;
"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
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?
] }
T{ ppc-backend } compiler-backend set-global
-6 cells set-profiler-prologues
+6 cells profiler-prologue set-global
JNE
] { } define-if-intrinsic
-10 set-profiler-prologues
-
"-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
] [
: arg0 EAX ;
: arg1 EDX ;
+: temp-reg EBX ;
: 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
] each
] if ;
-12 set-profiler-prologues
+12 profiler-prologue set-global
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
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 ;
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 ;
! 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 -- )
[
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
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 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
! 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
+compiler.constants ;
IN: bootstrap.x86
big-endian off
1 jit-code-format set
-: stack-frame-size 8 bootstrap-cells ;
+: stack-frame-size 4 bootstrap-cells ;
-: scan-save stack-reg 3 bootstrap-cells [+] ;
+[
+ ! Load word
+ temp-reg 0 [] MOV
+ ! Bump profiling counter
+ temp-reg profile-count-offset [+] 1 tag-fixnum ADD
+ ! Load word->code
+ temp-reg temp-reg word-code-offset [+] MOV
+ ! Compute word XT
+ temp-reg compiled-header-size ADD
+ ! Jump to XT
+ temp-reg JMP
+] rc-absolute-cell rt-literal 2 jit-profiling jit-define
[
- arg0 arg0 quot-array@ [+] MOV ! load array
- scan-reg arg0 scan@ [+] LEA ! initialize scan pointer
-] { } make jit-setup set
+ stack-frame-size PUSH ! save stack frame size
+ 0 PUSH ! push XT
+ arg1 PUSH ! alignment
+] rc-absolute-cell rt-xt 6 jit-prolog jit-define
-[
- 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
-] { } make jit-prolog set
-
-: advance-scan scan-reg bootstrap-cell ADD ;
-
-[
- advance-scan
+[
+ arg0 0 [] MOV ! load literal
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
+] rc-absolute-cell rt-literal 2 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
-] { } make jit-push-wrapper 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
-
-[
- arg0 scan-reg bootstrap-cell [+] MOV ! load word
- arg0 word-xt@ [+] JMP ! jump to word XT
-] { } make jit-word-jump set
-
-[
- 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
- 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
- ;
+ (JMP) drop ! go
+] rc-relative rt-primitive 3 jit-primitive jit-define
+
+[
+ (JMP) drop
+] rc-relative rt-xt 1 jit-word-jump jit-define
[
- load-branch
- xt-reg JMP
-] { } make jit-if-jump set
+ (CALL) drop
+] rc-relative rt-xt 1 jit-word-call jit-define
[
- load-branch
- scan-save scan-reg MOV ! save scan pointer
- xt-reg CALL ! call quotation
- scan-reg scan-save MOV ! restore scan pointer
-] { } make jit-if-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 [] 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
- xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt
- xt-reg JMP ! execute quotation
-] { } make jit-dispatch set
+ 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
-] { } 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
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
! 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
! 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
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." } ;
: 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 ;
{
{ [ 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. ] }
{ 13 [ retainstack-underflow. ] }
{ 14 [ retainstack-overflow. ] }
{ 15 [ memory-error. ] }
- { 16 [ primitive-error. ] }
} ; inline
M: kernel-error error. dup kernel-errors case ;
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 . ;
+
+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" ;
-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"
{ $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 } ;
-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
+"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 }
+{ $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"
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" } }
{ $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: 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
+"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." } ;
+
+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 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." } ;
SYMBOL: generic-1
-generic-1 T{ combination-1 } define-generic
+[
+ generic-1 T{ combination-1 } define-generic
-[ ] <method> object \ generic-1 define-method
+ [ ] <method> object \ generic-1 define-method
+] with-compilation-unit
-[ ] [ { combination-1 { object generic-1 } } forget-all ] unit-test
+[ ] [
+ [
+ { combination-1 { object generic-1 } } forget-all
+ ] with-compilation-unit
+] unit-test
GENERIC: 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
! 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 )
: delete-xref ( defspec -- )
dup unxref crossref get delete-at ;
+
+GENERIC: update-methods ( class -- )
+
+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 ;
+
+: add-once ( key assoc -- )
+ 2dup key? [ over redefine-error ] when dupd 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 -- )
+ over new-definitions get first key? [ dup redefine-error ] when
+ 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
+
+: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
+
+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
+ <definitions> new-definitions set
+ <definitions> old-definitions set
+ [ changed-words get keys recompile-hook get call ]
+ [ ] cleanup
+ ] with-scope ; inline
-! 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
<PRIVATE
over float-array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: float-array sequence
+INSTANCE: float-array simple-c-ptr
+INSTANCE: float-array c-ptr
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable
+++ /dev/null
-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 <computed> ] 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 <reversed> 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 <string> 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 ;
: 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 -- )
USING: help.markup help.syntax words debugger generator.fixup
-generator.registers quotations kernel vectors arrays ;
+generator.registers quotations kernel vectors arrays effects
+sequences ;
IN: generator
ARTICLE: "generator" "Compiled code generator"
{ $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 add-compiled-block }
-{ $subsection finalize-compile } ;
+{ $subsection generate } ;
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." } ;
-
-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: compiled
+{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
{ $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 } { "dependencies" sequence } { "dataflow" "a dataflow graph" } }
{ $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
HELP: define-intrinsics
quotations sequences system threads words ;
IN: generator
-SYMBOL: compiled-xts
+SYMBOL: compile-queue
+SYMBOL: compiled
-: save-xt ( word xt -- )
- swap dup unchanged-word compiled-xts get set-at ;
+: 5array 3array >r 2array r> append ;
-: compiling? ( word -- ? )
+: begin-compiling ( word -- )
+ f swap compiled get set-at ;
+
+: finish-compiling ( word literals words relocation labels code -- )
+ 5array swap compiled get set-at ;
+
+: queue-compile ( word -- )
{
- { [ dup compiled-xts get key? ] [ drop t ] }
- { [ dup word-changed? ] [ drop f ] }
- { [ t ] [ compiled? ] }
+ { [ dup compiled get key? ] [ drop ] }
+ { [ dup primitive? ] [ drop ] }
+ { [ dup deferred? ] [ drop ] }
+ { [ t ] [ dup compile-queue get set-at ] }
} cond ;
+: maybe-compile ( word -- )
+ dup compiled? [ drop ] [ queue-compile ] if ;
+
SYMBOL: compiling-word
SYMBOL: compiling-label
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 -- )
- pick f save-xt [
+ 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
- ] { } make fixup add-compiled-block save-xt ;
-
-: generate-profiler-prologue ( -- )
- compiled-stack-traces? get [
- compiling-word get %profiler-prologue
- ] when ;
+ ] { } make fixup finish-compiling ;
GENERIC: generate-node ( node -- next )
: generate ( word label node -- )
[
init-templates
- generate-profiler-prologue
%save-word-xt
%prologue-later
current-label-start define-label
[ generate-nodes ] with-node-iterator
] 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
-
-SYMBOL: batch-mode
-
-: compile-begins ( word -- )
- compiler-hook get call
- "quiet" get batch-mode get or [
- 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 ;
! 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 (compile)
+ dup maybe-compile
end-basic-block
tail-call? [
%jump f
! #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 ;
{ $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 } ;
{ $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." } ;
[ t ] [ \ + math-generic? ] unit-test
-[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
-
! Test math-combination
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
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 ;
quotations arrays vocabs ;
IN: generic
-PREDICATE: compound generic ( word -- ? )
- "combination" word-prop ;
+PREDICATE: word generic "combination" word-prop >boolean ;
M: generic definer drop f f ;
nip [ "Invalid method combination" throw ] curry [ ] like ;
: make-generic ( word -- )
- dup
- dup "combination" word-prop perform-combination
- define-compound ;
-
-: ?make-generic ( word -- )
- [ [ ] define-compound ] [ make-generic ] if-bootstrapping ;
+ dup dup "combination" word-prop perform-combination define ;
: init-methods ( word -- )
dup "methods" word-prop
: define-generic ( word combination -- )
dupd "combination" set-word-prop
- dup init-methods ?make-generic ;
+ dup init-methods make-generic ;
TUPLE: method loc def ;
] 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 -- )
forget-word ;
M: class update-methods ( class -- )
- [ drop ]
- [ class-usages implementors* [ make-generic ] each ]
- if-bootstrapping ;
+ class-usages implementors* [ make-generic ] each ;
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 ;
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." } ;
{ $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
-! 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 ;
: recursive-label ( word -- label/f )
recursive-state get at ;
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 {
: ensure-values ( seq -- )
meta-d [ add-inputs ] change d-in [ + ] change ;
-SYMBOL: terminated?
-
: current-effect ( -- effect )
d-in get meta-d get length <effect>
terminated? get over set-effect-terminated? ;
-SYMBOL: recorded
-
: init-inference ( -- )
terminated? off
V{ } clone meta-d set
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, ;
: 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 -- * )
over recorded get push
"inferred-effect" set-word-prop ;
-: infer-compound ( word -- effect )
+: infer-word ( word -- effect )
[
- init-inference
- 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
{ [ t ] [ dup infer-word make-call-node ] }
} cond ;
-M: word apply-object apply-word ;
-
-M: symbol apply-object apply-literal ;
-
TUPLE: recursive-declare-error word ;
: declared-infer ( word -- )
[ swap [ at ] curry map ] keep
[ set ] 2each ;
-: inline-closure ( word -- )
+: inline-word ( word -- )
dup inline-block over recursive-label? [
flatten-meta-d >r
drop join-values inline-block apply-infer
apply-infer node-child node-successor splice-node drop
] if ;
-M: compound apply-object
- [
+M: word apply-object
+ dup depends-on [
dup inline-recursive-label
- [ declared-infer ] [ inline-closure ] if
+ [ declared-infer ] [ inline-word ] if
] [
dup recursive-label
[ declared-infer ] [ apply-word ] if
] if-inline ;
-M: undefined apply-object
- drop "Undefined word" time-bomb ;
-
: with-infer ( quot -- effect dataflow )
[
[
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
] 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
+ ] with-compilation-unit
+
+ \ blah compiled?
] unit-test
GENERIC: detect-fx ( n -- n )
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." } ;
-! 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
: <computed> \ <computed> counter ;
C: <composed> 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
>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
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"
{ $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." } ;
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
-classes.union classes.predicate debugger bootstrap.image
-bootstrap.image.private io.launcher 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
[ [ 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
{ 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
-{ 1 1 } [ <process-stream> ] unit-test-effect
-{ 0 0 } [ idle-thread ] unit-test-effect
+\ idle-thread must-infer
! Incorrect stack declarations on inline recursive words should
! be caught
! 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 ;
+sequences prettyprint io effects kernel namespaces quotations
+words vocabs ;
+IN: inference
GENERIC: infer ( quot -- effect )
V{ } like meta-d set
f infer-quot
] with-infer nip ;
+
+: forget-errors ( -- )
+ all-words [ f "no-effect" set-word-prop ] each ;
! 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 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 inspector ;
+IN: inference.known-words
! Shuffle words
: infer-shuffle-inputs ( shuffle node -- )
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 ;
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
\ <word> make-flushable
-\ update-xt { word } { } <effect> "inferred-effect" set-word-prop
-
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
\ word-xt make-flushable
\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
\ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
+
+\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
--- /dev/null
+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." } ;
+
--- /dev/null
+! 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
! 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 )
! 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
{ $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:"
{ $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:"
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 ;
"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." }
[ 3drop datastack ] unit-test-fails
[ ] [ :c ] unit-test
+
+! Doesn't compile; important
+: foo 5 + 0 [ ] each ;
+
+[ drop foo ] unit-test-fails
+[ ] [ :c ] unit-test
: 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
: 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
: declare ( spec -- ) drop ;
+: do-primitive ( number -- ) "Improper primitive call" throw ;
+
PRIVATE>
{ $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" } } ;
: type-number ( class -- n )
type-numbers get at ;
-: tag-header ( n -- tagged )
+: tag-fixnum ( n -- tagged )
tag-bits get shift ;
: first-bignum ( -- n )
"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"
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." } ;
-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 )
+ <string-reader> stream-read-quot ;
+
[ [ ] ] [
- "USE: temporary hello" <string-reader> parse-interactive
+ "USE: temporary hello" parse-interactive
] unit-test
[
- file-vocabs
"debugger" use+
[ [ \ + 1 2 3 4 ] ]
[
"cont" set
[
- "\\ + 1 2 3 4"
- <string-reader>
- 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
+] with-file-vocabs
-[ ] [ "vocabs.loader.test.c" forget-vocab ] unit-test
+[ ] [
+ "vocabs.loader.test.c" forget-vocab
+] unit-test
[
- "USE: vocabs.loader.test.c" <string-reader>
- parse-interactive
+ "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
+
+[ ] [
+ "IN: temporary : hello\n\"world\" ;" parse-interactive
+ drop
+] unit-test
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
[ ] listener-hook set-global
-GENERIC: parse-interactive ( stream -- quot/f )
+GENERIC: stream-read-quot ( stream -- quot/f )
-: parse-interactive-step ( lines -- quot/f )
- [ parse-lines ] catch {
+: parse-lines-interactive ( lines -- quot/f )
+ [ parse-lines in get ] with-compilation-unit in set ;
+
+: read-quot-step ( lines -- quot/f )
+ [ parse-lines-interactive ] 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 stream-read-quot
+ duplex-stream-in stream-read-quot ;
-M: duplex-stream parse-interactive
- duplex-stream-in parse-interactive ;
+: read-quot ( -- quot ) stdio get stream-read-quot ;
: bye ( -- ) quit-flag on ;
: 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
" 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
{ $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." } ;
TUPLE: testing x y z ;
+[ save-image-and-exit ] unit-test-fails
+
[ ] [
num-types get [
type>class [
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes inference inference.dataflow io kernel
-kernel.private math.parser namespaces optimizer prettyprint
-prettyprint.backend sequences words arrays match macros
-assocs combinators.private ;
-IN: optimizer.debugger
-
-! A simple tool for turning dataflow IR into quotations, for
-! debugging purposes.
-
-GENERIC: node>quot ( ? node -- )
-
-TUPLE: comment node text ;
-
-M: comment pprint*
- "( " over comment-text " )" 3append
- swap comment-node present-text ;
-
-: comment, ( ? node text -- )
- rot [ \ comment construct-boa , ] [ 2drop ] if ;
-
-: values% ( prefix values -- )
- swap [
- %
- dup value? [
- value-literal unparse %
- ] [
- "@" % unparse %
- ] if
- ] curry each ;
-
-: effect-str ( node -- str )
- [
- " " over node-in-d values%
- " r: " over node-in-r values%
- " --" %
- " " over node-out-d values%
- " r: " swap node-out-r values%
- ] "" make 1 tail ;
-
-MACRO: match-choose ( alist -- )
- [ [ ] curry ] assoc-map [ match-cond ] curry ;
-
-MATCH-VARS: ?a ?b ?c ;
-
-: pretty-shuffle ( in out -- word/f )
- 2array {
- { { { ?a } { } } drop }
- { { { ?a ?b } { } } 2drop }
- { { { ?a ?b ?c } { } } 3drop }
- { { { ?a } { ?a ?a } } dup }
- { { { ?a ?b } { ?a ?b ?a ?b } } 2dup }
- { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup }
- { { { ?a ?b } { ?a ?b ?a } } over }
- { { { ?b ?a } { ?a ?b } } swap }
- { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick }
- { { { ?a ?b ?c } { ?c ?a ?b } } -rot }
- { { { ?a ?b ?c } { ?b ?c ?a } } rot }
- { { { ?a ?b } { ?b } } nip }
- { _ f }
- } match-choose ;
-
-M: #shuffle node>quot
- dup node-in-d over node-out-d pretty-shuffle
- [ , ] [ >r drop t r> ] if*
- dup effect-str "#shuffle: " swap append comment, ;
-
-: pushed-literals node-out-d [ value-literal ] map ;
-
-M: #push node>quot nip pushed-literals % ;
-
-DEFER: dataflow>quot
-
-: #call>quot ( ? node -- )
- dup node-param dup
- [ , dup effect-str comment, ] [ 3drop ] if ;
-
-M: #call node>quot #call>quot ;
-
-M: #call-label node>quot #call>quot ;
-
-M: #label node>quot
- [ "#label: " over node-param word-name append comment, ] 2keep
- node-child swap dataflow>quot , \ call , ;
-
-M: #if node>quot
- [ "#if" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map %
- \ if , ;
-
-M: #dispatch node>quot
- [ "#dispatch" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map ,
- \ dispatch , ;
-
-M: #return node>quot
- dup node-param unparse "#return " swap append comment, ;
-
-M: #>r node>quot nip node-in-d length \ >r <array> % ;
-
-M: #r> node>quot nip node-out-d length \ r> <array> % ;
-
-M: object node>quot dup class word-name comment, ;
-
-: (dataflow>quot) ( ? node -- )
- dup [
- 2dup node>quot node-successor (dataflow>quot)
- ] [
- 2drop
- ] if ;
-
-: dataflow>quot ( node ? -- quot )
- [ swap (dataflow>quot) ] [ ] make ;
-
-: print-dataflow ( quot ? -- )
- #! Print dataflow IR for a quotation. Flag indicates if
- #! annotations should be printed or not.
- >r dataflow optimize r> dataflow>quot pprint 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" }
{ $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 } ;
{ $subsection "parser-usage" }
"The parser can be extended."
{ $subsection "parsing-words" }
-{ $subsection "parser-lexer" } ;
+{ $subsection "parser-lexer" }
+{ $see-also "definitions" "definition-checking" } ;
ABOUT: "parser"
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 } "." } ;
+{ $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" } }
{ $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." } ;
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-file-vocabs with-interactive-vocabs } related-words
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
{ $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." }
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
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: 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: 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
{ $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." } ;
-
-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." } ;
-
-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 } "." } ;
+{ $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" } }
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." }
{ $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." } ;
-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." } ;
+
+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." } ;
IN: temporary
[
- file-vocabs
-
[ 1 CHAR: a ]
[ 0 "abcd" next-char ] unit-test
[ 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
[ \ 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
[ 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
[ "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
-
- [ f ] [
- "IN: temporary : foo ; TUPLE: foo ;" parse drop
- "foo" "temporary" lookup symbol?
- ] unit-test
+ [ "HEX: zzz" eval ] unit-test-fails
+ [ "OCT: 999" eval ] unit-test-fails
+ [ "BIN: --0" eval ] unit-test-fails
! Another funny bug
[ t ] [
{ "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
"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
"IN: temporary : smudge-me ;" <string-reader> "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
"IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "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 ;" <string-reader> "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 ;" <string-reader> "foo"
parse-stream drop
- "foo" source-file source-file-definitions assoc-size
+ "foo" source-file source-file-definitions first assoc-size
] unit-test
[ t ] [
[ t ] [
[
- "IN: temporary : x ; : y 3 throw ; parsing y"
+ "IN: temporary : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream
] catch parse-error?
] unit-test
<string-reader> "removing-the-predicate" parse-stream
] catch [ redefine-error? ] is?
] unit-test
-] with-scope
-[
- : FILE file get parsed ; parsing
+ [ t ] [
+ [
+ "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
+ <string-reader> "redefining-a-class-1" parse-stream
+ ] catch [ redefine-error? ] is?
+ ] unit-test
- FILE file set
+ [ ] [
+ "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test"
+ <string-reader> "redefining-a-class-2" parse-stream drop
+ ] unit-test
+
+ [ t ] [
+ [
+ "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+ ] catch [ redefine-error? ] is?
+ ] unit-test
+
+ [ ] [
+ "IN: temporary TUPLE: class-fwd-test ;"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+ ] unit-test
+
+ [ t ] [
+ [
+ "IN: temporary \\ class-fwd-test"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+ ] catch [ forward-error? ] is?
+ ] unit-test
+
+ [ ] [
+ "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+ ] unit-test
+
+ [ t ] [
+ [
+ "IN: temporary \\ class-fwd-test"
+ <string-reader> "redefining-a-class-3" parse-stream drop
+ ] catch [ forward-error? ] is?
+ ] unit-test
+
+ [ t ] [
+ [
+ "IN: temporary : foo ; TUPLE: foo ;"
+ <string-reader> "redefining-a-class-4" parse-stream drop
+ ] catch [ redefine-error? ] is?
+ ] unit-test
+] with-file-vocabs
+
+[
+ << file get parsed >> file set
: ~a ;
: ~b ~a ;
: ~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
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
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
-SYMBOL: file
-
TUPLE: lexer text line column ;
: <lexer> ( text -- lexer ) 1 0 lexer construct-boa ;
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) ;
+ location remember-definition ;
+
+: save-class-location ( class -- )
+ location remember-class ;
SYMBOL: parser-notes
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" ;
: CREATE ( -- word ) scan create-in ;
: CREATE-CLASS ( -- word )
- scan create-in dup predicate-word save-location ;
+ scan in get create
+ dup save-class-location
+ dup predicate-word dup set-word save-location ;
: word-restarts ( possibilities -- restarts )
natural-sort [
swap words-named word-restarts throw-restarts
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 ;
-
: check-forward ( str word -- word )
dup forward-reference? [
drop
: 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 -- )
+ new-definitions get [
+ dupd first key? [ staging-violation ] when
+ ] 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 ;
SYMBOL: bootstrap-syntax
-: file-vocabs ( -- )
- "scratchpad" in set
- { "syntax" "scratchpad" } set-use
- bootstrap-syntax get [ use get push ] when* ;
-
-: parse-fresh ( lines -- quot )
- [ file-vocabs parse-lines ] with-scope ;
+: with-file-vocabs ( quot -- )
+ [
+ "scratchpad" in set
+ { "syntax" "scratchpad" } set-use
+ bootstrap-syntax get [ use get push ] when*
+ call
+ ] with-scope ; inline
-SYMBOL: parse-hook
+: with-interactive-vocabs ( quot -- )
+ [
+ "scratchpad" in set
+ {
+ "arrays"
+ "assocs"
+ "combinators"
+ "compiler.errors"
+ "continuations"
+ "debugger"
+ "definitions"
+ "editors"
+ "generic"
+ "help"
+ "inspector"
+ "io"
+ "io.files"
+ "kernel"
+ "listener"
+ "math"
+ "memory"
+ "namespaces"
+ "prettyprint"
+ "sequences"
+ "slicing"
+ "sorting"
+ "strings"
+ "syntax"
+ "tools.annotations"
+ "tools.crossref"
+ "tools.memory"
+ "tools.profiler"
+ "tools.test"
+ "tools.time"
+ "vocabs"
+ "vocabs.loader"
+ "words"
+ "scratchpad"
+ } set-use
+ call
+ ] with-scope ; inline
-: do-parse-hook ( -- ) parse-hook get [ call ] when* ;
+: parse-fresh ( lines -- quot )
+ [ parse-lines ] with-file-vocabs ;
: parsing-file ( file -- )
"quiet" get [
"Loading " write <pathname> . 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 [
- 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
file get source-file-path =
] assoc-subset ;
+: removed-definitions ( -- definitions )
+ new-definitions 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
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
- ] [ ] [ undo-parsing ] cleanup
- ] no-parse-hook ;
+ 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 ;
: parse-file ( file -- quot )
[
- [ parsing-file ] keep
- [ ?resource-path <file-reader> ] keep
- parse-stream
+ [
+ [ parsing-file ] keep
+ [ ?resource-path <file-reader> ] keep
+ parse-stream
+ ] with-compiler-errors
] [
over parse-file-restarts rethrow-restarts
drop parse-file
: 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 ;
: 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 ;
-: 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 )
[
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
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
[ "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
[ ] [ \ general-t see ] unit-test
-[ ] [ \ compound see ] unit-test
+[ ] [ \ generic see ] unit-test
[ ] [ \ duplex-stream see ] 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 ;
{
"USING: io kernel sequences words ;"
"IN: temporary"
- ": retain-stack-layout"
+ ": retain-stack-layout ( x -- )"
" dup stream-readln stream-readln"
- " >r [ define-compound ] map r>"
- " define-compound ;"
+ " >r [ define ] map r>"
+ " define ;"
} ;
[ t ] [
{
"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"
{
"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 ;"
} ;
: another-narrow-test
{
"IN: temporary"
- ": another-narrow-layout"
+ ": another-narrow-layout ( -- obj )"
" H{"
" { 1 2 }"
" { 3 4 }"
"another-narrow-layout" another-narrow-test check-see
] unit-test
+: class-see-test
+ {
+ "IN: temporary"
+ "TUPLE: class-see-layout ;"
+ ""
+ "IN: temporary"
+ "GENERIC: class-see-layout ( x -- y )"
+ ""
+ "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
[ [ + ] ] [
: 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* ;
: pprint-; \ ; pprint-word ;
: (see) ( spec -- )
- [
- <colon dup synopsis*
- <block dup definition pprint-elements block>
- dup definer nip [ pprint-word ] when* declarations.
- block>
- ] with-use nl ;
+ <colon dup synopsis*
+ <block dup definition pprint-elements block>
+ 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
+ <colon \ UNION: pprint-word
dup pprint-word
- members pprint-elements pprint-; ;
+ members pprint-elements pprint-; block> ;
M: mixin-class see-class*
- \ MIXIN: pprint-word
+ <block \ MIXIN: pprint-word
dup pprint-word <block
dup members [
hard line-break
\ INSTANCE: pprint-word pprint-word pprint-word
- ] curry* each block> ;
+ ] curry* each block> block> ;
M: predicate-class see-class*
<colon \ PREDICATE: pprint-word
pprint-; block> block> ;
M: tuple-class see-class*
- \ TUPLE: pprint-word
+ <colon \ TUPLE: pprint-word
dup pprint-word
"slot-names" word-prop [ text ] each
- pprint-; ;
+ pprint-; block> ;
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? [
- nl [ dup see-class* ] with-pprint nl
+ [
+ dup seeing-word dup see-class*
+ ] with-use nl
] when drop ;
: see-methods ( generic -- seq )
[ 2array ] curry map ;
M: word see
- dup (see)
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
HELP: colon
{ $class-description "A " { $link block } " section. When printed as a " { $link long-section } ", indents every line except the first." }
-{ $notes "Colon sections are used to enclose compound definitions printed by " { $link see } "." } ;
+{ $notes "Colon sections are used to enclose word definitions printed by " { $link see } "." } ;
HELP: <colon
{ $description "Begins a " { $link colon } " section." } ;
HELP: quotation
{ $description "The class of quotations. See " { $link "syntax-quots" } " for syntax and " { $link "quotations" } " for general information." } ;
-HELP: <quotation>
-{ $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." } ;
M: callable equal?
over callable? [ sequence= ] [ 2drop f ] if ;
-: <quotation> ( n -- quot )
- f <array> array>quotation ; inline
-
M: quotation length quotation-array length ;
M: quotation nth-unsafe quotation-array nth-unsafe ;
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"
{ $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" } }
[ 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
: 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
: 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 ;
[ 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
: writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ;
-PREDICATE: compound slot-writer
- "writing" word-prop >boolean ;
+PREDICATE: word slot-writer "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
{ { $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" }
}
} ;
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 } "." } ;
dup source-file-path ?resource-path file-modified
swap set-source-file-modified ;
-: record-checksum ( source-file contents -- )
- crc32 swap set-source-file-checksum ;
+: record-checksum ( contents source-file -- )
+ >r crc32 r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> swap source-file-uses
swap quot-uses keys over set-source-file-uses
xref-source ;
+: record-definitions ( file -- )
+ new-definitions get swap set-source-file-definitions ;
+
: <source-file> ( path -- source-file )
- { set-source-file-path } \ source-file construct ;
+ <definitions>
+ { set-source-file-path set-source-file-definitions }
+ \ source-file construct ;
: source-file ( path -- source-file )
source-files get [ <source-file> ] cache ;
M: pathname where pathname-string 1 2array ;
-: forget-source ( path -- )
+M: pathname forget
+ pathname-string
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 ;
+: forget-source ( path -- )
+ [ <pathname> forget ] with-compilation-unit ;
+
+: rollback-source-file ( source-file -- )
+ dup source-file-definitions new-definitions get [ union ] 2map
+ 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
{ $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
"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"
{ $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{
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 ";" }
{ $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" } }
{ $description "Marks the end of a block of private word definitions." } ;
{ POSTPONE: <PRIVATE POSTPONE: PRIVATE> } 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
"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
+[
+ { "]" "}" ";" ">>" } [ define-delimiter ] each
+
+ "PRIMITIVE:" [
+ "Primitive definition is not supported" throw
+ ] define-syntax
+
+ "CS{" [
+ "Call stack literals are not supported" throw
+ ] define-syntax
+
+ "!" [ lexer get next-line ] define-syntax
-"PRIMITIVE:" [
- "Primitive definition is not supported" throw
-] define-syntax
-
-"CS{" [
- "Call stack literals are not supported" throw
-] define-syntax
-
-"!" [ lexer get next-line ] define-syntax
-
-"#!" [ POSTPONE: ! ] define-syntax
-
-"IN:" [ scan set-in ] define-syntax
-
-"PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
-
-"<PRIVATE" [
- POSTPONE: PRIVATE> in get ".private" append set-in
-] define-syntax
-
-"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
-"OCT:" [ 8 parse-base ] define-syntax
-"BIN:" [ 2 parse-base ] define-syntax
-
-"f" [ f parsed ] define-syntax
-"t" "syntax" lookup define-symbol
-
-"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
-
-"P\"" [
- lexer get skip-blank parse-string <pathname> parsed
-] define-syntax
-
-"[" [ \ ] [ >quotation ] parse-literal ] define-syntax
-"{" [ \ } [ >array ] parse-literal ] define-syntax
-"V{" [ \ } [ >vector ] parse-literal ] define-syntax
-"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
-"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
-"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
-"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
-"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
-"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
-
-"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
-
-"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
-
-"GENERIC:" [
- CREATE dup reset-word
- define-simple-generic
-] define-syntax
-
-"GENERIC#" [
- CREATE dup reset-word
- scan-word <standard-combination> define-generic
-] define-syntax
-
-"MATH:" [
- CREATE dup reset-word
- T{ math-combination } define-generic
-] define-syntax
-
-"HOOK:" [
- CREATE dup reset-word scan-word
- <hook-combination> define-generic
-] define-syntax
-
-"M:" [
- f set-word
- location >r
- scan-word bootstrap-word scan-word
- [ parse-definition <method> -rot define-method ] 2keep
- 2array r> (save-location)
-] define-syntax
-
-"UNION:" [
- CREATE-CLASS parse-definition define-union-class
-] define-syntax
-
-"MIXIN:" [
- CREATE-CLASS define-mixin-class
-] define-syntax
-
-"INSTANCE:" [ scan-word scan-word add-mixin-instance ] define-syntax
-
-"PREDICATE:" [
- scan-word
- CREATE-CLASS
- parse-definition define-predicate-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
-
-"FORGET:" [ scan use get assoc-stack forget ] 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
+ "#!" [ POSTPONE: ! ] define-syntax
+
+ "IN:" [ scan set-in ] define-syntax
+
+ "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
+
+ "<PRIVATE" [
+ POSTPONE: PRIVATE> in get ".private" append set-in
+ ] define-syntax
+
+ "USE:" [ scan 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
+
+ "f" [ f parsed ] define-syntax
+ "t" "syntax" lookup define-symbol
+
+ "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
+
+ "P\"" [
+ lexer get skip-blank parse-string <pathname> parsed
+ ] define-syntax
+
+ "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
+ "{" [ \ } [ >array ] parse-literal ] define-syntax
+ "V{" [ \ } [ >vector ] parse-literal ] define-syntax
+ "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
+ "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
+ "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
+ "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
+ "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
+ "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
+
+ "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
+
+ "DEFER:" [
+ scan in get create
+ dup old-definitions get first delete-at
+ set-word
+ ] define-syntax
+
+ ":" [
+ CREATE dup reset-generic parse-definition define
+ ] define-syntax
+
+ "GENERIC:" [
+ CREATE dup reset-word
+ define-simple-generic
+ ] define-syntax
+
+ "GENERIC#" [
+ CREATE dup reset-word
+ scan-word <standard-combination> define-generic
+ ] define-syntax
+
+ "MATH:" [
+ CREATE dup reset-word
+ T{ math-combination } define-generic
+ ] define-syntax
+
+ "HOOK:" [
+ CREATE dup reset-word scan-word
+ <hook-combination> define-generic
+ ] define-syntax
+
+ "M:" [
+ f set-word
+ location >r
+ scan-word bootstrap-word scan-word
+ [ parse-definition <method> -rot define-method ] 2keep
+ 2array r> remember-definition
+ ] define-syntax
+
+ "UNION:" [
+ CREATE-CLASS parse-definition define-union-class
+ ] define-syntax
+
+ "MIXIN:" [
+ CREATE-CLASS define-mixin-class
+ ] define-syntax
+
+ "INSTANCE:" [
+ location >r
+ scan-word scan-word 2dup add-mixin-instance
+ <mixin-instance> r> remember-definition
+ ] define-syntax
+
+ "PREDICATE:" [
+ scan-word
+ CREATE-CLASS
+ parse-definition define-predicate-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
+
+ "FORGET:" [ scan use get assoc-stack forget ] 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
+
+ "<<" [ \ >> parse-until >quotation call ] define-syntax
+] with-compilation-unit
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"
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
100 200 <point> "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
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
[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
-[ ] [ "IN: temporary SYMBOL: #x TUPLE: #x ;" eval ] unit-test
-
! Hashcode breakage
TUPLE: empty ;
[ f ] [ \ <yo-momma> 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 ;
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 )
[ 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 ;
-
- C: <erg's-reshape-problem> erg's-reshape-problem
-
- [ ] [
- "IN: temporary TUPLE: erg's-reshape-problem a b c d ;" eval
- ] unit-test
-
+TUPLE: erg's-reshape-problem a b c d ;
- [ 1 2 ] [
- ! <erg's-reshape-problem> hasn't been recompiled yet, so
- ! we just created a tuple using an obsolete layout
- 1 2 3 <erg's-reshape-problem>
-
- ! 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
+C: <erg's-reshape-problem> erg's-reshape-problem
! 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
+[ ] [ 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
+
[ t ] [
- {
- <erg's-reshape-problem>
- cons-test-1
- cons-test-2
- cons-test-3
- } [ changed-words get key? ] all?
+ [
+ "IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
+ ] catch [ check-tuple? ] is?
] unit-test
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." } ;
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
"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
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
[ 1 ] [ "count-me" get-global ] unit-test
[ ] [
- "bob" "vocabs.loader.test.b" create [ ] define-compound
+ [
+ "bob" "vocabs.loader.test.b" create [ ] define
+ ] with-compilation-unit
] unit-test
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
[ 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
+ "vocabs.loader.test.b" vocab-files [ forget-source ] each
] unit-test
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
"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
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
: 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? ;
-: 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 ]
- cleanup
- ] keep source-was-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
drop no-vocab
] if ;
-: require ( vocab -- ) load-vocab drop ;
+: require ( vocab -- )
+ load-vocab drop ;
: run ( vocab -- )
dup load-vocab vocab-main [
dup update-roots
dup modified-sources swap modified-docs ;
+: 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 ] no-parse-hook ;
+ append prune require-all ;
: refresh ( prefix -- ) to-refresh do-refresh ;
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 )
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 ;
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
+++ /dev/null
-USE: vocabs.loader.test.f
+++ /dev/null
-USE: vocabs.loader.test.e
-
-! a syntax error
-123 iterate-next
source-loaded? docs-loaded? ;
: <vocab> ( 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 )
M: f set-vocab-docs-loaded? 2drop ;
: create-vocab ( name -- vocab )
- dictionary get [ <vocab> ] cache
- t over set-vocab-source-loaded? ;
+ dictionary get [ <vocab> ] cache ;
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 ;
-
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
[ 2drop t ] [ swap CHAR: . add head? ] if ;
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 ;
"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 }
"Testing if a word object is part of a vocabulary:"
{ $subsection interned? } ;
-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: "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 <word> }
+{ $subsection gensym }
+{ $subsection define-temp } ;
+
+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" } ")."
"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."
{ $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? }
+"Deferred words throw an error when called:"
{ $subsection undefined }
-{ $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."
{ $subsection set-word-def }
"An " { $emphasis "XT" } " (execution token) is the machine code address of a word:"
{ $subsection word-xt }
-{ $subsection update-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."
+"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."
{ $subsection word }
{ $subsection word? }
{ $subsection "interned-words" }
+{ $subsection "uninterned-words" }
{ $subsection "word-definition" }
{ $subsection "word-props" }
{ $subsection "word.private" }
$low-level-note
{ $side-effects "word" } ;
-HELP: undefined
-{ $class-description "The class of undefined words created by " { $link POSTPONE: DEFER: } "." } ;
-
-{ undefined POSTPONE: DEFER: } related-words
+HELP: deferred
+{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ;
-HELP: compound
-{ $description "The class of compound words created by " { $link POSTPONE: : } "." } ;
+{ deferred POSTPONE: DEFER: } related-words
HELP: primitive
{ $description "The class of primitive words." } ;
{ $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." }
+{ $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: 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
+HELP: define
{ $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
{ $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." } ;
{ $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." }
+{ $description "Defines a 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" }
+ "This word must be called from inside " { $link with-compilation-unit } "."
+} ;
+
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." } ;
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 -- )
+{ $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 }" } " - 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 } "." } ;
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
-vocabs continuations ;
+vocabs continuations tuples ;
IN: temporary
[ 4 ] [
- "poo" "scratchpad" create [ 2 2 + ] define-compound
- "poo" "scratchpad" lookup execute
+ [
+ "poo" "temporary" create [ 2 2 + ] define
+ ] with-compilation-unit
+ "poo" "temporary" lookup execute
] unit-test
[ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-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
[
[ t ] [ \ array? "array?" "arrays" lookup = ] unit-test
- "test-scope" "scratchpad" create drop
+ [ ] [ "test-scope" "scratchpad" create drop ] unit-test
] with-scope
[ "test-scope" ] [
[ f ] [ gensym gensym = ] unit-test
-[ f ] [ 123 compound? ] unit-test
-
-: colon-def ;
-[ t ] [ \ colon-def compound? ] unit-test
-
SYMBOL: a-symbol
-[ f ] [ \ a-symbol compound? ] unit-test
[ t ] [ \ a-symbol symbol? ] unit-test
! See if redefining a generic as a colon def clears some
FORGET: foe
! xref should not retain references to gensyms
-gensym [ * ] define-compound
+[ ] [
+ [ gensym [ * ] define ] 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
+ ] with-compilation-unit
+] unit-test
+
[ f ] [ "x" get crossref get at ] unit-test
! more xref buggery
[ 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
[ ] [ "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
-quot-uses-a [ 2 3 + ] define-compound
+[ ] [
+ [
+ quot-uses-a [ 2 3 + ] define
+ ] 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
+ ] with-compilation-unit
+] unit-test
[ { + } ] [ \ quot-uses-b uses ] unit-test
+
+[ t ] [
+ [ "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
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 ;
-M: word definition drop f ;
+M: word definer drop \ : \ ; ;
-PREDICATE: word undefined ( obj -- ? ) word-def not ;
-M: undefined definer drop \ DEFER: f ;
+M: word definition word-def ;
-PREDICATE: word compound ( obj -- ? ) word-def quotation? ;
+TUPLE: undefined ;
-M: compound definer drop \ : \ ; ;
+: undefined ( -- * ) \ undefined construct-empty throw ;
-M: compound definition word-def ;
+PREDICATE: word deferred ( obj -- ? )
+ word-def [ undefined ] = ;
+M: deferred definer drop \ DEFER: f ;
+M: deferred definition drop f ;
-PREDICATE: word primitive ( obj -- ? ) word-def fixnum? ;
-M: primitive definer drop \ PRIMITIVE: f ;
-
-PREDICATE: word symbol ( obj -- ? ) word-def t eq? ;
+PREDICATE: word symbol ( obj -- ? )
+ dup <wrapper> 1array swap word-def sequence= ;
M: symbol definer drop \ SYMBOL: f ;
+M: symbol definition drop f ;
+
+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 ;
M: word uses ( word -- seq )
word-def quot-uses keys ;
-M: compound redefined* ( word -- )
- dup changed-word
+M: word redefined* ( word -- )
{ "inferred-effect" "base-case" "no-effect" } reset-props ;
-<PRIVATE
-
-: definition-changed? ( word def -- ? )
- swap word-def = not ;
-
: define ( word def -- )
- 2dup definition-changed? [
- over redefined
- over unxref
- over set-word-def
- dup update-xt
- dup word-vocabulary [
- dup changed-word dup xref
- ] when drop
- ] [
- 2drop
- ] if ;
-
-PRIVATE>
-
-: define-symbol ( word -- ) t define ;
-
-: intern-symbol ( word -- )
- dup undefined? [ define-symbol ] [ drop ] if ;
-
-: define-compound ( word def -- ) [ ] like define ;
+ [ ] like
+ over unxref
+ over redefined
+ over set-word-def
+ dup changed-word
+ dup word-vocabulary [ dup xref ] when drop ;
: define-declared ( word def effect -- )
pick swap "declared-effect" set-word-prop
- define-compound ;
+ define ;
: make-inline ( word -- )
t "inline" set-word-prop ;
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 ;
: reset-word ( word -- )
{
+ "unannotated-def"
"parsing" "inline" "foldable"
"predicating"
"reading" "writing"
"G:" \ gensym counter number>string append f <word> ;
: define-temp ( quot -- word )
- gensym [ swap define-compound ] keep ;
+ gensym dup rot define ;
: reveal ( word -- )
dup word-name over word-vocabulary vocab-words set-at ;
: forget-word ( word -- )
dup delete-xref
- dup unchanged-word
(forget-word) ;
M: word forget forget-word ;
: ?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
assoc-heap-assoc assoc-empty? ;
M: assoc-heap heap-length ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
+ assoc-heap-assoc assoc-size ;
M: assoc-heap heap-peek ( assoc-heap -- value key )
assoc-heap-heap heap-peek ;
: 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 ( -- )
IN: bootstrap.help
: load-help
- t load-help? set-global
+ "alien.syntax" require
+ "compiler" require
- vocabs
- [ vocab-root ] subset
- [ vocab-source-loaded? ] subset
- [
- dup vocab-docs-loaded? [
- drop
- ] [
- dup vocab-root swap load-docs
- ] if
- ] each
+ t load-help? set-global
- "help.handbook" require
+ [ 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
- global [ "help" use+ ] bind ;
+ "help.handbook" require ;
load-help
USING: system vocabs vocabs.loader kernel combinators
-namespaces sequences ;
+namespaces sequences io.backend ;
IN: bootstrap.io
"bootstrap.compiler" vocab [
{ [ wince? ] [ "windows.ce" ] }
} cond append require
] when
+
+init-io
+init-stdio
-USING: kernel vocabs vocabs.loader sequences namespaces parser ;
+USING: vocabs.loader sequences ;
{
"bootstrap.image"
"tools.annotations"
"tools.crossref"
- "tools.deploy"
+ ! "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
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> timestamp
C: <dt> dt
-DEFER: gmt-offset
-
: month-names
{
"Not a month" "January" "February" "March" "April" "May" "June"
] 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
!
! 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
{
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
-} compile-vocabs
+} [ words ] map concat compile-batch
"Importing Cocoa classes..." print
{
: pasteboard-error ( error -- f )
"Pasteboard does not hold a string" <NSString>
- 0 swap rot set-void*-nth f ;
+ 0 spin set-void*-nth f ;
: ?pasteboard-string ( pboard error -- str/f )
over pasteboard-string? [
: 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 ;
: preserving ( predicate -- quot )
dup infer effect-in
- dup 1+ swap rot
+ dup 1+ spin
[ , , nkeep , nrot ]
bake ;
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 <method> spin define-method ;
-USING: help.markup help.syntax libc kernel destructors ;
+USING: help.markup help.syntax libc kernel ;
IN: destructors
HELP: free-always
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
{ $code "[ 10 malloc free-always ] with-destructors" }
-}
-{ $see-also } ;
+} ;
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 ;
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
! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg strings promises sequences math math.parser
- namespaces words quotations arrays hashtables io
+USING: kernel peg strings promises sequences math math.parser
+ namespaces words quotations arrays hashtables io
io.streams.string assocs memoize ;
IN: fjsc
'identifier-ends' ,
'identifier-middle' ,
'identifier-ends' ,
- ] { } make seq [
- concat >string f <ast-identifier>
+ ] { } make seq [
+ concat >string f <ast-identifier>
] action ;
"--" token sp hide ,
'effect-name' sp repeat0 ,
")" token sp hide ,
- ] { } make seq [
- first2 <ast-stack-effect>
+ ] { } make seq [
+ first2 <ast-stack-effect>
] action ;
MEMO: 'define' ( -- parser )
[
":" token sp hide ,
- 'identifier' sp [ ast-identifier-value ] action ,
+ 'identifier' sp [ ast-identifier-value ] action ,
'stack-effect' sp optional ,
'expression' ,
";" token sp hide ,
MEMO: 'quotation' ( -- parser )
[
"[" token sp hide ,
- 'expression' [ ast-expression-values ] action ,
+ 'expression' [ ast-expression-values ] action ,
"]" token sp hide ,
] { } make seq [ first <ast-quotation> ] action ;
MEMO: 'word' ( -- parser )
[
"\\" token sp hide ,
- 'identifier' sp ,
+ 'identifier' sp ,
] { } make seq [ first ast-identifier-value f <ast-word> ] action ;
MEMO: 'atom' ( -- parser )
[
- 'identifier' ,
+ 'identifier' ,
'integer' [ <ast-number> ] action ,
'string' [ <ast-string> ] action ,
] { } make choice ;
[
[
"#!" token sp ,
- "!" token sp ,
+ "!" token sp ,
] { } make choice hide ,
[
dup CHAR: \n = swap CHAR: \r = or not
MEMO: 'USE:' ( -- parser )
[
"USE:" token sp hide ,
- 'identifier' sp ,
+ 'identifier' sp ,
] { } make seq [ first ast-identifier-value <ast-use> ] action ;
MEMO: 'IN:' ( -- parser )
MEMO: 'hashtable' ( -- parser )
[
"H{" token sp hide ,
- 'expression' [ ast-expression-values ] action ,
+ 'expression' [ ast-expression-values ] action ,
"}" token sp hide ,
] { } make seq [ first <ast-hashtable> ] action ;
] { } make choice ;
MEMO: 'expression' ( -- parser )
- [
+ [
[
'comment' ,
'parsing-word' sp ,
'hashtable' sp ,
'word' sp ,
'atom' sp ,
- ] { } make choice repeat0 [ <ast-expression> ] action
+ ] { } make choice repeat0 [ <ast-expression> ] action
] delay ;
MEMO: 'statement' ( -- parser )
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
-USING: alien.syntax math prettyprint system ;
+USING: alien.syntax math prettyprint system combinators
+vocabs.loader ;
IN: hardware-info
SYMBOL: os
: 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
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 ;
: 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
! 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 ;
USING: tools.deploy.config ;
H{
+ { deploy-c-types? f }
+ { deploy-ui? f }
+ { deploy-reflection 1 }
{ deploy-math? f }
- { deploy-word-defs? f }
{ deploy-word-props? f }
+ { deploy-word-defs? f }
{ deploy-name "Hello world (console)" }
{ "stop-after-last-window?" t }
- { deploy-c-types? f }
{ deploy-compiler? f }
{ deploy-io 2 }
- { deploy-ui? f }
- { deploy-reflection 1 }
}
"{ -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"
} ;
[ "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
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\" ;" <string-reader> "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
"IN: temporary USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "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
"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
M: link definition article-content ;
-M: link see (see) ;
-
M: link synopsis*
- \ ARTICLE: pprint-word
+ dup definer.
dup link-name pprint*
article-title pprint* ;
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. ;
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 help.lint ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
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." }
}
"Solaris/x86 fixes. (Samuel Tardieu)"
"Linux/AMD64 port works again."
} ;
+
+{ <array> <string> <sbuf> <vector> <byte-array> <bit-array> <float-array> }
+related-words
+
+{ >array >quotation >string >sbuf >vector >byte-array >bit-array >float-array }
+related-words
-USING: help.markup help.crossref help.topics help.syntax
-definitions io prettyprint inspector help.lint 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"
{ $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 }
{ $subsection "help.lint" }
{ $subsection "help-impl" } ;
+IN: help
ABOUT: "help"
HELP: $title
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: } "." } ;
+++ /dev/null
-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" } "." } ;
+++ /dev/null
-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: } "." } ;
USING: tools.test parser vocabs help.syntax namespaces ;
[
- file-vocabs
-
[ "foobar" ] [
"IN: temporary USE: help.syntax ABOUT: \"foobar\"" eval
"temporary" vocab vocab-help
"IN: temporary USE: help.syntax ABOUT: xyz" eval
"temporary" vocab vocab-help
] unit-test
-] with-scope
+] with-file-vocabs
! 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:
: ARTICLE:
location >r
\ ; parse-until >array [ first2 ] keep 2 tail <article>
- over add-article >link r> (save-location) ; parsing
+ over add-article >link r> remember-definition ; parsing
: ABOUT:
scan-word dup parsing? [
hash>query %
] if
] "" make ;
-
+
! 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+
--- /dev/null
+IN: temporary
+USING: tools.test tools.test.inference io.launcher ;
+
+\ <process-stream> must-infer
! 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+
: <process-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
>r <mapped-file> r>
[ keep ] curry
[ close-mapped-file ] [ ] cleanup ; inline
-
-USE-IF: unix? io.unix.mmap
-USE-IF: windows? io.windows.mmap
-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 -- )
! 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
-USING: io.backend kernel system ;
+USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer
SYMBOL: sniffer-type
HOOK: <sniffer> io-backend ( obj -- sniffer )
-USE-IF: bsd? io.sniffer.bsd
+bsd? [ "io.sniffer.bsd" require ] when
! 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 )
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
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
-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 )
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
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
rot dup length swap <slice> find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 swap rot <slice> <reversed> find-nearest-segment ;
+ swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.
: 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 ;
: 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 ;
-! 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
+
<PRIVATE
TUPLE: lambda vars body ;
MACRO: with-locals ( form -- quot ) lambda-rewrite ;
-: :: "lambda" (::) drop define-compound ; parsing
+: :: "lambda" (::) drop define ; parsing
: MACRO:: "lambda-macro" (::) (MACRO:) ; parsing
{ 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 \ :: \ ; ;
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 ;
"lambda-macro" word-prop lambda-body ;
M: lambda-macro synopsis*
- "lambda-macro" \ MACRO:: lambda-word-synopsis ;
+ "lambda-macro" lambda-word-synopsis ;
PRIVATE>
: (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: \ ; ;
"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> }
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 ;
[ 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
: 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
: 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 ;
: 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 } ;
{ $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
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: temporary
+USING: multi-methods tools.test kernel math arrays sequences
+prettyprint strings classes hashtables assocs namespaces
+debugger continuations ;
+
+[ { 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 ] [ 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
+
+[ 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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! 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 arrays.lib
+debugger io ;
+IN: multi-methods
+
+TUPLE: method loc def ;
+
+: <method> { set-method-def } \ method construct ;
+
+: 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 ;
+
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- picker [ >r ] swap [ r> swap ] 3append ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap "predicate" word-prop append ;
+
+: multi-predicate ( classes -- quot )
+ dup length <reversed>
+ [ 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 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 generic -- quot )
+ >r congruify-methods sorted-methods r> multi-dispatch-quot ;
+
+M: standard-combination perform-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 ] keep
+ standard-combination append ;
+
+: make-generic ( word -- )
+ 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 define-standard-generic ; parsing
+
+: 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> <method> -rot
+ r> first2 swap add* >array ;
+
+: METHOD:
+ location
+ >r parse-method >r add-method r> r>
+ remember-definition ; parsing
+
+! For compatibility
+: M:
+ scan-word 1array scan-word parse-definition <method>
+ -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 definer.
+ dup seeing-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.
+ unclip pprint* pprint* ;
+
+syntax:M: method-spec forget
+ unclip [ delete-at ] with-methods ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes inference inference.dataflow io kernel
+kernel.private math.parser namespaces optimizer prettyprint
+prettyprint.backend sequences words arrays match macros
+assocs combinators.private ;
+IN: optimizer.debugger
+
+! A simple tool for turning dataflow IR into quotations, for
+! debugging purposes.
+
+GENERIC: node>quot ( ? node -- )
+
+TUPLE: comment node text ;
+
+M: comment pprint*
+ "( " over comment-text " )" 3append
+ swap comment-node present-text ;
+
+: comment, ( ? node text -- )
+ rot [ \ comment construct-boa , ] [ 2drop ] if ;
+
+: values% ( prefix values -- )
+ swap [
+ %
+ dup value? [
+ value-literal unparse %
+ ] [
+ "@" % unparse %
+ ] if
+ ] curry each ;
+
+: effect-str ( node -- str )
+ [
+ " " over node-in-d values%
+ " r: " over node-in-r values%
+ " --" %
+ " " over node-out-d values%
+ " r: " swap node-out-r values%
+ ] "" make 1 tail ;
+
+MACRO: match-choose ( alist -- )
+ [ [ ] curry ] assoc-map [ match-cond ] curry ;
+
+MATCH-VARS: ?a ?b ?c ;
+
+: pretty-shuffle ( in out -- word/f )
+ 2array {
+ { { { ?a } { } } drop }
+ { { { ?a ?b } { } } 2drop }
+ { { { ?a ?b ?c } { } } 3drop }
+ { { { ?a } { ?a ?a } } dup }
+ { { { ?a ?b } { ?a ?b ?a ?b } } 2dup }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup }
+ { { { ?a ?b } { ?a ?b ?a } } over }
+ { { { ?b ?a } { ?a ?b } } swap }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick }
+ { { { ?a ?b ?c } { ?c ?a ?b } } -rot }
+ { { { ?a ?b ?c } { ?b ?c ?a } } rot }
+ { { { ?a ?b } { ?b } } nip }
+ { _ f }
+ } match-choose ;
+
+M: #shuffle node>quot
+ dup node-in-d over node-out-d pretty-shuffle
+ [ , ] [ >r drop t r> ] if*
+ dup effect-str "#shuffle: " swap append comment, ;
+
+: pushed-literals node-out-d [ value-literal ] map ;
+
+M: #push node>quot nip pushed-literals % ;
+
+DEFER: dataflow>quot
+
+: #call>quot ( ? node -- )
+ dup node-param dup ,
+ [ dup effect-str ] [ "empty call" ] if comment, ;
+
+M: #call node>quot #call>quot ;
+
+M: #call-label node>quot #call>quot ;
+
+M: #label node>quot
+ [ "#label: " over node-param word-name append comment, ] 2keep
+ node-child swap dataflow>quot , \ call , ;
+
+M: #if node>quot
+ [ "#if" comment, ] 2keep
+ node-children swap [ dataflow>quot ] curry map %
+ \ if , ;
+
+M: #dispatch node>quot
+ [ "#dispatch" comment, ] 2keep
+ node-children swap [ dataflow>quot ] curry map ,
+ \ dispatch , ;
+
+M: #return node>quot
+ dup node-param unparse "#return " swap append comment, ;
+
+M: #>r node>quot nip node-in-d length \ >r <array> % ;
+
+M: #r> node>quot nip node-out-d length \ r> <array> % ;
+
+M: object node>quot dup class word-name comment, ;
+
+: (dataflow>quot) ( ? node -- )
+ dup [
+ 2dup node>quot node-successor (dataflow>quot)
+ ] [
+ 2drop
+ ] if ;
+
+: dataflow>quot ( node ? -- quot )
+ [ swap (dataflow>quot) ] [ ] make ;
+
+: print-dataflow ( quot ? -- )
+ #! Print dataflow IR for a quotation. Flag indicates if
+ #! annotations should be printed or not.
+ >r dataflow optimize r> dataflow>quot pprint nl ;
USING: help.syntax help.markup peg peg.search ;
HELP: tree-write
-{ $values
+{ $values
{ "object" "an object" } }
-{ $description
+{ $description
"Write the object to the standard output stream, unless "
"it is an array, in which case recurse through the array "
"writing each object to the stream." }
{ $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ;
HELP: search
-{ $values
- { "string" "a string" }
- { "parser" "a peg based parser" }
- { "seq" "a sequence" }
+{ $values
+ { "string" "a string" }
+ { "parser" "a peg based parser" }
+ { "seq" "a sequence" }
}
-{ $description
+{ $description
"Returns a sequence containing the parse results of all substrings "
"from the input string that successfully parse using the "
"parser."
}
-
+
{ $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" }
{ $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" }
{ $see-also replace } ;
-
+
HELP: replace
-{ $values
- { "string" "a string" }
- { "parser" "a peg based parser" }
- { "result" "a string" }
+{ $values
+ { "string" "a string" }
+ { "parser" "a peg based parser" }
+ { "result" "a string" }
}
-{ $description
+{ $description
"Returns a copy of the original string but with all substrings that "
"successfully parse with the given parser replaced with "
"the result of that parser."
-}
+}
{ $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" }
{ $see-also search } ;
IN: temporary
{ V{ 123 456 } } [
- "abc 123 def 456" 'integer' search
+ "abc 123 def 456" 'integer' search
] unit-test
{ V{ 123 "hello" 456 } } [
- "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search
+ "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search
] unit-test
{ "abc 246 def 912" } [
- "abc 123 def 456" 'integer' [ 2 * number>string ] action replace
+ "abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.streams.string sequences strings
combinators peg memoize arrays ;
-IN: peg.search
+IN: peg.search
: tree-write ( object -- )
- {
+ {
{ [ dup number? ] [ write1 ] }
{ [ dup string? ] [ write ] }
{ [ dup sequence? ] [ [ tree-write ] each ] }
: search ( string parser -- seq )
any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
- parse-result-ast [ ] subset
+ parse-result-ast [ ] subset
] [
drop { }
] if ;
] 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 ;
-USING: qualified help.markup help.syntax ;
+USING: help.markup help.syntax ;
+IN: qualified
HELP: QUALIFIED:
{ $syntax "QUALIFIED: vocab" }
: 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
+
: cut-find ( seq pred -- before after )
dupd find drop dup [ cut ] when ;
M: complex (serialize) ( obj -- )
"c" write
- dup real (serialize)
- imaginary (serialize) ;
+ dup real-part (serialize)
+ imaginary-part (serialize) ;
M: ratio (serialize) ( obj -- )
"r" write
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup kernel sequences shuffle ;\r
-\r
-HELP: npick\r
-{ $values { "n" "a number" } }\r
-{ $description "A generalisation of " { $link dup } ", " \r
-{ $link over } " and " { $link pick } " that can work " \r
-"for any stack depth. The nth item down the stack will be copied and "\r
-"placed on the top of the stack."\r
-} \r
-{ $examples\r
- { $example "USE: shuffle" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }\r
-}\r
-{ $see-also dup over pick } ;\r
-\r
-HELP: ndup\r
-{ $values { "n" "a number" } }\r
-{ $description "A generalisation of " { $link dup } ", " \r
-{ $link 2dup } " and " { $link 3dup } " that can work " \r
-"for any number of items. The n topmost items on the stack will be copied and "\r
-"placed on the top of the stack."\r
-} \r
-{ $examples\r
- { $example "USE: shuffle" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }\r
-}\r
-{ $see-also dup 2dup 3dup } ;\r
-\r
-HELP: nnip\r
-{ $values { "n" "a number" } }\r
-{ $description "A generalisation of " { $link nip } " and " { $link 2nip } \r
-" that can work " \r
-"for any number of items."\r
-} \r
-{ $examples\r
- { $example "USE: shuffle" "1 2 3 4 3 nnip .s" "4" }\r
-}\r
-{ $see-also nip 2nip } ;\r
-\r
-HELP: ndrop\r
-{ $values { "n" "a number" } }\r
-{ $description "A generalisation of " { $link drop } \r
-" that can work " \r
-"for any number of items."\r
-} \r
-{ $examples\r
- { $example "USE: shuffle" "1 2 3 4 3 ndrop .s" "1" }\r
-}\r
-{ $see-also drop 2drop 3drop } ;\r
-\r
-HELP: nrot\r
-{ $values { "n" "a number" } }\r
-{ $description "A generalisation of " { $link rot } " that works for any "\r
-"number of items on the stack. " \r
-} \r
-{ $examples\r
- { $example "USE: shuffle" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }\r
-}\r
-{ $see-also rot -nrot } ;\r
-\r
-HELP: -nrot\r
-{ $values { "n" "a number" } }\r
-{ $description "A generalisation of " { $link -rot } " that works for any "\r
-"number of items on the stack. " \r
-} \r
-{ $examples\r
- { $example "USE: shuffle" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }\r
-}\r
-{ $see-also rot nrot } ;\r
-\r
-ARTICLE: { "shuffle" "overview" } "Extra shuffle words"\r
-"A number of stack shuffling words for those rare times when you "\r
-"need to deal with tricky stack situations and can't refactor the "\r
-"code to work around it." \r
-{ $subsection ndup } \r
-{ $subsection npick } \r
-{ $subsection nrot } \r
-{ $subsection -nrot } \r
-{ $subsection nnip } \r
-{ $subsection ndrop } ;\r
-\r
-IN: shuffle\r
+! 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
-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
: 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
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 }
! 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 ( word -- )
+ dup "unannotated-def" word-prop [
+ [
+ dup "unannotated-def" word-prop define
+ ] with-compilation-unit
+ ] [ drop ] if ;
+
: annotate ( word quot -- )
- over >r >r word-def r> call r>
- swap define-compound do-parse-hook ;
- 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 .
: breakpoint ( word -- )
[ \ break add* ] annotate ;
-: breakpoint-if ( quot word -- )
- [ [ [ break ] when ] swap 3append ] annotate ;
+: breakpoint-if ( word quot -- )
+ [ [ [ break ] when ] rot 3append ] curry annotate ;
: load-everything ( -- )
all-vocabs-seq
[ vocab-name dangerous? not ] subset
- [ [ require ] each ] no-parse-hook ;
+ require-all ;
: unrooted-child-vocabs ( prefix -- seq )
dup empty? [ CHAR: . add ] unless
: load-children ( prefix -- )
all-child-vocabs values concat
- [ [ require ] each ] no-parse-hook ;
+ require-all ;
: vocab-status-string ( vocab -- string )
{
--- /dev/null
+! 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 .
+ <process-stream>
+ dup duplex-stream-out stream-close
+ copy-lines ;
+
+SYMBOL: deploy-implementation
+
+HOOK: deploy* deploy-implementation ( vocab -- )
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" } "." } ;
-! 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
-<PRIVATE
+: deploy ( vocab -- ) deploy* ;
-: 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 ;
-
-: stage2 ( vm flags -- )
- >r "-i=" boot-image-name append 2array r> append dup .
- <process-stream>
- 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 -- )
-
-USE-IF: macosx? tools.deploy.macosx
-
-USE-IF: winnt? tools.deploy.windows
+macosx? [ "tools.deploy.macosx" require ] when
+winnt? [ "tools.deploy.windows" require ] when
-! 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
over <NSString> rot parent-directory <NSString>
-> 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 ;
{ } 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 ;
! 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
! 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 )
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
+ ] bind
+ ] keep stage2 open-in-explorer ;
quotations sequences splitting strings threads vectors words ;
IN: tools.interpreter
+: walk ( quot -- ) \ break add* call ;
+
TUPLE: interpreter continuation ;
: <interpreter> interpreter construct-empty ;
<PRIVATE
-: (step-into-call) \ break add* call ;
-
-: (step-into-if) ? (step-into-call) ;
+: (step-into-if) ? walk ;
: (step-into-dispatch)
- nth (step-into-call) ;
+ nth walk ;
: (step-into-execute) ( word -- )
dup "step-into" word-prop [
call
] [
- dup compound? [
- word-def (step-into-call)
- ] [
+ dup primitive? [
execute break
+ ] [
+ word-def walk
] if
] ?if ;
M: word (step-into) (step-into-execute) ;
{
- { call [ (step-into-call) ] }
- { (throw) [ (step-into-call) ] }
+ { call [ walk ] }
+ { (throw) [ walk ] }
{ execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
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
] 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
+! 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
: 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 ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Single-stepper breakpoint hook
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: tools.walker
-USING: kernel sequences continuations ;
-
-: walk ( quot -- ) \ break add* call ;
-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 } }
{ $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
-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."
IN: temporary
USING: tools.test.inference ui.gadgets.books ;
-{ 2 1 } [ <book> ] unit-test-effect
+\ <book> must-infer
-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."
{ $values { "target" object } { "toolbar" gadget } }
{ $description "Creates a row of " { $link <command-button> } " gadgets invoking commands on " { $snippet "target" } ". The commands are taken from the " { $snippet "\"toolbar\"" } " command group of each class in " { $snippet "classes" } "." } ;
-HELP: <commands-menu>
-{ $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 }
} <radio-buttons> "religion" set
] unit-test
-{ 2 1 } [ <radio-buttons> ] unit-test-effect
+\ <radio-buttons> must-infer
-{ 2 1 } [ <toggle-buttons> ] unit-test-effect
+\ <toggle-buttons> must-infer
-{ 2 1 } [ <checkbox> ] unit-test-effect
+\ <checkbox> must-infer
[ 0 ] [
"religion" get gadget-child radio-control-value
] with-grafted-gadget
] unit-test
-{ 0 1 } [ <editor> ] unit-test-effect
+\ <editor> must-infer
"hello" <model> <field> "field" set
: 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 ;
-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
-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:"
{ $subsection control-value }
{ $subsection set-control-value }
{ $see-also "models" } ;
-
-ABOUT: "ui-control-impl"
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
] string-out print
-{ 0 1 } [ <gadget> ] 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
-
-{ 1 0 } [ relayout ] unit-test-effect
-{ 1 0 } [ relayout-1 ] unit-test-effect
-{ 1 1 } [ pref-dim ] unit-test-effect
+\ <gadget> must-infer
+\ unparent must-infer
+\ add-gadget must-infer
+\ add-gadgets must-infer
+\ clear-gadget must-infer
+
+\ relayout must-infer
+\ relayout-1 must-infer
+\ pref-dim must-infer
-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." } ;
: 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 [
-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."
-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."
-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: <commands-menu>
+{ $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 } }
-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:"
-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
-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
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
-{ 1 1 } [ <scroller> ] unit-test-effect
+\ <scroller> must-infer
-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: <status-bar>
{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
-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 <track> } "." } ;
-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 <viewport> } "." } ;
-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." } ;
{ { $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." }
}
: 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 ( -- )
[ "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" <editor> [ set-editor-string ] keep
"op" get invoke-command
USING: tools.test tools.test.ui ui.tools.browser
tools.test.inference ;
-{ 0 1 } [ <browser-gadget> ] unit-test-effect
+\ <browser-gadget> must-infer
[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
-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: <debugger>
{ $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 } } }
-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" } }
-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" } "."
$nl
"Interactors are created by calling " { $link <interactor> } "."
$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." } ;
IN: temporary
USING: ui.tools.interactor tools.test.inference ;
-{ 1 1 } [ <interactor> ] unit-test-effect
+\ <interactor> must-infer
-! 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
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
history output
continuation quot busy?
-vars
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 ;
+ use swap
+ interactor-continuation continuation-name
+ assoc-stack ;
: init-caret-help ( interactor -- )
dup editor-caret 100 <delay> swap set-interactor-help ;
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
t over set-interactor-busy?
interactor-continuation schedule-thread-with ;
-: interactor-finish ( obj interactor -- )
+: 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
- dup gadget-model clear-doc
- interactor-continue ;
-
-: interactor-eval ( interactor -- )
- [
- [ editor-string ] keep dup interactor-quot call
- ] in-thread drop ;
+ [ clear-input ] curry in-thread ;
: 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? [
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 ;
-
: 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 ;
-
-: handle-interactive ( str/f interactor -- )
+ drop parse-lines-interactive
+ ] [
+ >r f swap set-interactor-busy? drop r>
+ dup delegate unexpected-eof? [ drop f ] when
+ ] recover ;
+
+: 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 parse-interactive
- [ save-vars ] keep
- [ [ handle-interactive ] interactor-yield ] keep
- restore-vars ;
+M: interactor stream-read-quot
+ [ 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 }
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
[ ] [ <listener-gadget> "listener" set ] unit-test
"listener" get [
- { "kernel" } [ vocab-words ] map use associate
- "listener" get listener-gadget-input set-interactor-vars
-
[ "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
<pane> <interactor> "i" set
- H{ } "i" get set-interactor-vars
[ 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 ] [
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 ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
dup empty? [
drop
] [
- [ [ [ run-file ] each ] no-parse-hook ] curry
- call-listener
+ [ [ run-file ] each ] curry call-listener
] if ;
: com-EOF ( listener -- )
get-listener [ word-completion-string ] keep
listener-gadget-input user-input ;
-: quot-action ( interactor -- quot )
- dup editor-string swap
- 2dup add-interactor-history
- select-all ;
+: quot-action ( interactor -- lines )
+ dup control-value
+ dup "\n" join pick add-interactor-history
+ swap select-all ;
TUPLE: stack-display ;
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* ;
ui.tools.search ui.tools.traceback ui.tools.workspace generic
help.topics inference inspector io.files io.styles kernel
namespaces parser prettyprint quotations tools.annotations
-editors tools.profiler tools.test tools.time tools.walker
+editors tools.profiler tools.test tools.time tools.interpreter
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
tools.browser classes ;
{ +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
+: com-forget ( defspec -- )
+ [ forget ] with-compilation-unit ;
-[ dup reloadable-definition? swap vocab-spec? or ] \ forget
-H{ } define-operation
+[ definition? ] \ com-forget H{ } define-operation
! Words
[ word? ] \ insert-word H{
M: word com-stack-effect word-def com-stack-effect ;
-[ compound? ] \ com-stack-effect H{
+[ word? ] \ com-stack-effect H{
{ +listener+ t }
} define-operation
"These commands operate on the entire contents of the input area."
[ ]
[ quot-action ]
-[ parse ]
+[ [ parse-lines ] with-compilation-unit ]
define-operation-map
USING: editors help.markup help.syntax inspector io listener
-parser prettyprint tools.profiler tools.walker ui.commands
+parser prettyprint tools.profiler tools.interpreter ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser
ui.tools.interactor ui.tools.listener ui.tools.operations
tools.interpreter.debug tools.test.inference tools.test.ui ;
IN: temporary
-{ 0 1 } [ <walker> ] unit-test-effect
+\ <walker> must-infer
[ ] [ <walker> "walker" set ] unit-test
workspace-listener
listener-gadget-input
"ok" on
- parse-interactive
+ stream-read-quot
"c" get continue-with
] in-thread drop
IN: temporary
USING: tools.test tools.test.inference ui.tools ;
-{ 0 1 } [ <workspace> ] unit-test-effect
+\ <workspace> must-infer
{ 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
[ 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)
] 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
: 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* ;
! 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
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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
+
+{
+ { [ linux? ] [ "unix.linux" ] }
+ { [ bsd? ] [ "unix.bsd" ] }
+ { [ solaris? ] [ "unix.solaris" ] }
+} cond require
! 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
[ $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 ) [
-! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel namespaces sequences words io assocs\r
-quotations strings parser arrays xml.data xml.writer debugger\r
-splitting vectors ;\r
-IN: xml.utilities\r
-\r
-! * System for words specialized on tag names\r
-\r
-TUPLE: process-missing process tag ;\r
-M: process-missing error.\r
- "Tag <" write\r
- dup process-missing-tag print-name\r
- "> not implemented on process process " write\r
- process-missing-process word-name print ;\r
-\r
-: run-process ( tag word -- )\r
- 2dup "xtable" word-prop\r
- >r dup name-tag r> at* [ 2nip call ] [\r
- drop \ process-missing construct-boa throw\r
- ] if ;\r
-\r
-: PROCESS:\r
- CREATE\r
- dup H{ } clone "xtable" set-word-prop\r
- dup [ run-process ] curry define-compound ; parsing\r
-\r
-: TAG:\r
- scan scan-word\r
- parse-definition\r
- swap "xtable" word-prop\r
- rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;\r
- parsing\r
-\r
-\r
-! * Common utility functions\r
-\r
-: build-tag* ( items name -- tag )\r
- assure-name swap >r f r> <tag> ;\r
-\r
-: build-tag ( item name -- tag )\r
- >r 1array r> build-tag* ;\r
-\r
-: standard-prolog ( -- prolog )\r
- T{ prolog f "1.0" "iso-8859-1" f } ;\r
-\r
-: build-xml ( tag -- xml )\r
- standard-prolog { } rot { } <xml> ;\r
-\r
-: children>string ( tag -- string )\r
- tag-children\r
- dup [ string? ] all?\r
- [ "XML tag unexpectedly contains non-text children" throw ] unless\r
- concat ;\r
-\r
-: children-tags ( tag -- sequence )\r
- tag-children [ tag? ] subset ;\r
-\r
-: first-child-tag ( tag -- tag )\r
- tag-children [ tag? ] find nip ;\r
-\r
-! * Utilities for searching through XML documents\r
-! These all work from the outside in, top to bottom.\r
-\r
-: with-delegate ( object quot -- object )\r
- over clone >r >r delegate r> call r>\r
- [ set-delegate ] keep ; inline\r
-\r
-GENERIC# xml-each 1 ( quot tag -- ) inline\r
-M: tag xml-each\r
- [ call ] 2keep\r
- swap tag-children [ swap xml-each ] curry* each ;\r
-M: object xml-each\r
- call ;\r
-M: xml xml-each\r
- >r delegate r> xml-each ;\r
-\r
-GENERIC# xml-map 1 ( quot tag -- tag ) inline\r
-M: tag xml-map\r
- swap clone over >r swap call r> \r
- swap [ tag-children [ swap xml-map ] curry* map ] keep \r
- [ set-tag-children ] keep ;\r
-M: object xml-map\r
- call ;\r
-M: xml xml-map\r
- swap [ swap xml-map ] with-delegate ;\r
-\r
-: xml-subset ( quot tag -- seq ) ! quot: tag -- ?\r
- V{ } clone rot [\r
- swap >r [ swap call ] 2keep rot r>\r
- swap [ [ push ] keep ] [ nip ] if\r
- ] xml-each nip ;\r
-\r
-GENERIC# xml-find 1 ( quot tag -- tag ) inline\r
-M: tag xml-find\r
- [ call ] 2keep swap rot [\r
- f swap\r
- [ nip over >r swap xml-find r> swap dup ] find\r
- 2drop ! leaves result of quot\r
- ] unless nip ;\r
-M: object xml-find\r
- keep f ? ;\r
-M: xml xml-find\r
- >r delegate r> xml-find ;\r
-\r
-GENERIC# xml-inject 1 ( quot tag -- ) inline\r
-M: tag xml-inject\r
- swap [\r
- swap [ call ] keep\r
- [ xml-inject ] keep\r
- ] change-each ;\r
-M: object xml-inject 2drop ;\r
-M: xml xml-inject >r delegate >r xml-inject ;\r
-\r
-! * Accessing part of an XML document\r
-! for tag- words, a start means that it searches all children\r
-! and no star searches only direct children\r
-\r
-: tag-named? ( name elem -- ? )\r
- dup tag? [ names-match? ] [ 2drop f ] if ;\r
-\r
-: tag-named* ( tag name/string -- matching-tag )\r
- assure-name swap [ dupd tag-named? ] xml-find nip ;\r
-\r
-: tags-named* ( tag name/string -- tags-seq )\r
- assure-name swap [ dupd tag-named? ] xml-subset nip ;\r
-\r
-: tag-named ( tag name/string -- matching-tag )\r
- ! like get-name-tag but only looks at direct children,\r
- ! not all the children down the tree.\r
- assure-name swap [ tag-named? ] curry* find nip ;\r
-\r
-: tags-named ( tag name/string -- tags-seq )\r
- assure-name swap [ tag-named? ] curry* subset ;\r
-\r
-: assert-tag ( name name -- )\r
- names-match? [ "Unexpected XML tag found" throw ] unless ;\r
-\r
-: insert-children ( children tag -- )\r
- dup tag-children [ push-all ]\r
- [ >r V{ } like r> set-tag-children ] if ;\r
-\r
-: insert-child ( child tag -- )\r
- >r 1vector r> insert-children ;\r
-\r
-: tag-with-attr? ( elem attr-value attr-name -- ? )\r
- rot dup tag? [ at = ] [ drop f ] if ;\r
-\r
-: tag-with-attr ( tag attr-value attr-name -- matching-tag )\r
- assure-name [ tag-with-attr? ] 2curry find nip ;\r
-\r
-: tags-with-attr ( tag attr-value attr-name -- tags-seq )\r
- assure-name [ tag-with-attr? ] 2curry subset ;\r
-\r
-: tag-with-attr* ( tag attr-value attr-name -- matching-tag )\r
- assure-name [ tag-with-attr? ] 2curry xml-find nip ;\r
-\r
-: tags-with-attr* ( tag attr-value attr-name -- tags-seq )\r
- assure-name [ tag-with-attr? ] 2curry xml-subset ;\r
-\r
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)\r
- "id" tag-with-attr ;\r
-\r
-: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )\r
- >r >r tags-named* r> r> tags-with-attr ;\r
-\r
+! 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 vectors ;
+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 )
+ assure-name swap >r f r> <tag> ;
+
+: build-tag ( item name -- tag )
+ >r 1array r> build-tag* ;
+
+: standard-prolog ( -- prolog )
+ T{ prolog f "1.0" "iso-8859-1" f } ;
+
+: build-xml ( tag -- xml )
+ standard-prolog { } rot { } <xml> ;
+
+: 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
+! for tag- words, a start means that it searches all children
+! and no star searches only direct children
+
+: tag-named? ( name elem -- ? )
+ dup tag? [ names-match? ] [ 2drop f ] if ;
+
+: tag-named* ( tag name/string -- matching-tag )
+ assure-name swap [ dupd tag-named? ] xml-find nip ;
+
+: tags-named* ( tag name/string -- tags-seq )
+ assure-name swap [ dupd tag-named? ] 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 [ tag-named? ] curry* find nip ;
+
+: tags-named ( tag name/string -- tags-seq )
+ assure-name swap [ tag-named? ] curry* subset ;
+
+: assert-tag ( name name -- )
+ names-match? [ "Unexpected XML tag found" throw ] unless ;
+
+: insert-children ( children tag -- )
+ dup tag-children [ push-all ]
+ [ >r V{ } like r> set-tag-children ] if ;
+
+: insert-child ( child tag -- )
+ >r 1vector r> insert-children ;
+
+: tag-with-attr? ( elem attr-value attr-name -- ? )
+ rot dup tag? [ at = ] [ drop f ] if ;
+
+: tag-with-attr ( tag attr-value attr-name -- matching-tag )
+ assure-name [ tag-with-attr? ] 2curry find nip ;
+
+: tags-with-attr ( tag attr-value attr-name -- tags-seq )
+ assure-name [ tag-with-attr? ] 2curry subset ;
+
+: tag-with-attr* ( tag attr-value attr-name -- matching-tag )
+ assure-name [ tag-with-attr? ] 2curry xml-find nip ;
+
+: tags-with-attr* ( tag attr-value attr-name -- tags-seq )
+ assure-name [ tag-with-attr? ] 2curry xml-subset ;
+
+: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
+ "id" tag-with-attr ;
+
+: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )
+ >r >r tags-named* r> r> tags-with-attr ;
echo "OS, ARCH, or WORD is empty. Please report this"
exit 5
fi
-
+
MAKE_TARGET=$OS-$ARCH-$WORD
MAKE_IMAGE_TARGET=$ARCH.$WORD
BOOT_IMAGE=boot.$ARCH.$WORD.image
make_boot_image() {
./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
check_ret factor
-
+
}
install_libraries() {
source misc/version.sh
-rm -rf .git
+rm -rf .git .gitignore
cd ..
tar cfz Factor-$VERSION.tar.gz factor/
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
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
CELL frame_scan(F_STACK_FRAME *frame)
{
if(frame_type(frame) == QUOTATION_TYPE)
- return tag_fixnum(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;
}
REGISTER_UNTAGGED(quot);
if(quot->compiledp == F)
- jit_compile(quot);
+ jit_compile(tag_object(quot));
UNREGISTER_UNTAGGED(quot);
UNREGISTER_UNTAGGED(callstack);
F_STACK_FRAME *inner = innermost_stack_frame(callstack);
type_check(QUOTATION_TYPE,frame_executing(inner));
- 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;
for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan);
- /* If the block is not finalized, the words area contains pointers to
- words in the data heap rather than XTs in the code heap */
- switch(compiled->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 */
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)
{
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 */
{
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)
{
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;
-
- while(iter < end)
- {
- *iter = forward_xt(*iter);
- iter++;
- }
-}
+ begin_scan();
-void forward_block_xts(void)
-{
- F_BLOCK *scan = first_block(&code_heap);
+ CELL obj;
- while(scan)
+ while((obj = next_object()) != F)
{
- 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);
+ update_word_xt(word);
}
+ else if(type_of(obj) == QUOTATION_TYPE)
+ {
+ F_QUOTATION *quot = untag_object(obj);
- scan = next_block(&code_heap,scan);
+ if(quot->compiledp != F)
+ set_quot_xt(quot,quot->code);
+ }
}
+
+ /* End the heap scan */
+ gc_off = false;
}
void compact_heap(F_HEAP *heap)
if(scan->status == B_ALLOCATED && scan != scan->forwarding)
memcpy(scan->forwarding,scan,scan->size);
-
scan = next;
}
}
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);
return undefined_symbol;
}
-static CELL xt_offset;
-
/* 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))
{
case RT_PRIMITIVE:
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;
+ obj = get(CREF(words_start,REL_ARGUMENT(rel)));
+ switch(type_of(obj))
+ {
+ 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:
- 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 + 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 */
}
}
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());
-
- 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;
+ F_REL *rel = (F_REL *)reloc_start;
+ F_REL *rel_end = (F_REL *)literals_start;
- F_FIXNUM absolute_value = compute_code_rel(rel,
- code_start,literals_start,words_start);
+ while(rel < rel_end)
+ {
+ CELL offset = rel->offset + code_start;
- apply_relocation(REL_CLASS(rel),offset,absolute_value);
+ F_FIXNUM absolute_value = compute_code_rel(rel,
+ code_start,literals_start,words_start);
- rel++;
+ 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 */
}
}
-/* 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)
-{
- 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,
- 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)
{
return start;
}
+/* Might GC */
F_COMPILED *add_compiled_block(
CELL type,
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 = array_capacity(relocation) * sizeof(unsigned int);
CELL words_length = (words ? array_capacity(words) * CELLS : 0);
- CELL literals_length = (literals ? array_capacity(literals) * CELLS : 0);
+ CELL literals_length = array_capacity(literals) * CELLS;
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
- REGISTER_UNTAGGED(rel);
+ REGISTER_UNTAGGED(relocation);
REGISTER_UNTAGGED(words);
REGISTER_UNTAGGED(literals);
UNREGISTER_UNTAGGED(literals);
UNREGISTER_UNTAGGED(words);
- UNREGISTER_UNTAGGED(rel);
+ UNREGISTER_UNTAGGED(relocation);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
header->reloc_length = rel_length;
header->literals_length = literals_length;
header->words_length = words_length;
- header->finalized = false;
here += sizeof(F_COMPILED);
here += code_length;
/* relation info */
- if(rel)
- {
- deposit_integers(here,rel,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)
return header;
}
-void set_word_xt(F_WORD *word, F_COMPILED *compiled)
+void set_word_code(F_WORD *word, F_COMPILED *compiled)
{
- word->code = compiled;
- word->xt = (XT)(compiled + 1);
-
- if(!profiling_p())
- word->xt += profiler_prologue();
+ if(compiled->type != WORD_TYPE)
+ critical_error("bad param to set_word_xt",(CELL)compiled);
+ word->code = compiled;
word->compiledp = T;
}
-DEFINE_PRIMITIVE(add_compiled_block)
+/* Allocates memory */
+void default_word_code(F_WORD *word)
{
- 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_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));
+ REGISTER_UNTAGGED(word);
+ jit_compile(word->def);
+ UNREGISTER_UNTAGGED(word);
+
+ word->code = untag_quotation(word->def)->code;
+ word->compiledp = F;
}
-/* After batch compiling a bunch of words, perform various fixups to make them
-executable */
-DEFINE_PRIMITIVE(finalize_compile)
+DEFINE_PRIMITIVE(modify_code_heap)
{
- F_ARRAY *array = untag_array(dpop());
+ F_ARRAY *alist = untag_array(dpop());
+
+ bool rescan_code_heap = false;
- /* 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_ARRAY *pair = untag_array(array_nth(alist,i));
+
F_WORD *word = untag_word(array_nth(pair,0));
- F_COMPILED *compiled = untag_word(array_nth(pair,1))->code;
- set_word_xt(word,compiled);
+
+ if(word->vocabulary != F)
+ rescan_code_heap = true;
+
+ CELL data = array_nth(pair,1);
+
+ if(data == F)
+ {
+ REGISTER_UNTAGGED(alist);
+ default_word_code(word);
+ UNREGISTER_UNTAGGED(alist);
+ }
+ else
+ {
+ F_ARRAY *compiled_code = untag_array(data);
+
+ 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,
+ code,
+ labels,
+ relocation,
+ words,
+ literals);
+
+ UNREGISTER_UNTAGGED(word);
+ UNREGISTER_UNTAGGED(alist);
+
+ set_word_code(word,compiled);
+ }
+
+ REGISTER_UNTAGGED(alist);
+ update_word_xt(word);
+ UNREGISTER_UNTAGGED(alist);
}
- /* perform relocation */
- for(i = 0; i < count; i++)
+ /* 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
{
- 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);
+ 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);
+ }
}
}
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 default_word_code(F_WORD *word);
-void set_word_xt(F_WORD *word, F_COMPILED *compiled);
+void set_word_code(F_WORD *word, F_COMPILED *compiled);
F_COMPILED *add_compiled_block(
CELL type,
CELL compiled_code_format(void);
-DECLARE_PRIMITIVE(add_compiled_block);
-DECLARE_PRIMITIVE(finalize_compile);
+DECLARE_PRIMITIVE(modify_code_heap);
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)):
#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);
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);
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)):
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);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
void throw_impl(CELL quot, F_STACK_FRAME *rewind);
-#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
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
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,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)):
- 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 */
- 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 */
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
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);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
{
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;
/* 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);
}
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)
+{
+ 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,
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
+ collect_gc_locals();
collect_stack(extra_roots_region,extra_roots);
save_stacks();
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:
}
}
-void collect_callstack_object(F_CALLSTACK *callstack)
+void do_code_slots(CELL scan)
{
- 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;
{
case WORD_TYPE:
word = (F_WORD *)scan;
- if(collecting_code && word->compiledp != F)
- 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);
}
/* 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())
-#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 */
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 */
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)
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);
}
{
ERROR_EXPIRED = 0,
ERROR_IO,
- ERROR_UNDEFINED_WORD,
+ ERROR_NOT_IMPLEMENTED,
ERROR_TYPE,
ERROR_DIVIDE_BY_ZERO,
ERROR_SIGNAL,
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_MEMORY,
- ERROR_NOT_IMPLEMENTED,
} F_ERRORTYPE;
void fatal_error(char* msg, CELL tagged);
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);
p->console = false;
}
+/* Do some initialization that we do once only */
+void do_stage1_init(void)
+{
+ fprintf(stderr,"*** Stage 2 early init... ");
+ fflush(stderr);
+
+ begin_scan();
+
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == WORD_TYPE)
+ {
+ F_WORD *word = untag_object(obj);
+ default_word_code(word);
+ update_word_xt(word);
+ }
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ iterate_code_heap(relocate_code_block);
+
+ userenv[STAGE2_ENV] = T;
+
+ fprintf(stderr,"done\n");
+ fflush(stderr);
+}
+
/* Get things started */
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)
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;
+
+ if(!stage2)
+ do_stage1_init();
}
INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
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)
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++)
/* 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);
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
+ if(stage2)
{
- code_fixup((CELL)&word->xt);
code_fixup((CELL)&word->code);
+ if(word->profiling) code_fixup((CELL)&word->profiling);
+ update_word_xt(word);
}
}
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));
}
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)
{
CELL reloc_length; /* # bytes */
CELL literals_length; /* # bytes */
CELL words_length; /* # bytes */
- CELL finalized; /* has finalize_code_block() been called on this yet? */
- CELL padding[2];
+ CELL padding[3];
} F_COMPILED;
/* Assembly code makes assumptions about the layout of this 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 */
/* tagged byte array holding a C string */
CELL path;
/* OS-specific handle */
- void* dll;
+ void *dll;
} F_DLL;
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;
{
DIR* dir = opendir(unbox_char_string());
GROWABLE_ARRAY(result);
+ REGISTER_ROOT(result);
if(dir != NULL)
{
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)
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)
DEFINE_PRIMITIVE(os_envs)
{
GROWABLE_ARRAY(result);
+ REGISTER_ROOT(result);
TCHAR *env = GetEnvironmentStrings();
TCHAR *finger = env;
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;
FreeEnvironmentStrings(env);
+ UNREGISTER_ROOT(result);
GROWABLE_TRIM(result);
- dpush(tag_object(result));
+ dpush(result);
}
long exception_handler(PEXCEPTION_POINTERS pe)
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)
primitive_float_greater,
primitive_float_greatereq,
primitive_word,
- primitive_update_xt,
primitive_word_xt,
primitive_drop,
primitive_2drop,
primitive_tag,
primitive_cwd,
primitive_cd,
- primitive_add_compiled_block,
+ primitive_modify_code_heap,
primitive_dlopen,
primitive_dlsym,
primitive_dlclose,
primitive_end_scan,
primitive_size,
primitive_die,
- primitive_finalize_compile,
primitive_fopen,
primitive_fgetc,
primitive_fread,
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
- primitive_strip_compiled_quotations,
primitive_os_envs,
};
#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_FIXNUM profiler_prologue(void)
-{
- return to_fixnum(userenv[PROFILER_PROLOGUE_ENV]);
+ 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)
- {
- if(type_of(word->def) == QUOTATION_TYPE)
- word->xt = 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);
}
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();
- /* Step 1 - Update word XTs and saved callstack objects */
+ /* Update word XTs and saved callstack objects */
begin_scan();
CELL obj;
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 */
- /* 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)
-bool profiling_p(void);
-F_FIXNUM profiler_prologue(void);
+bool profiling_p;
DECLARE_PRIMITIVE(profiling);
+F_COMPILED *compile_profiling_stub(F_WORD *word);
+void update_word_xt(F_WORD *word);
/* 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)
+ 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];
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];
}
-#define EMIT(name) { \
- REGISTER_UNTAGGED(array); \
- GROWABLE_APPEND(result,untag_object(userenv[name])); \
- UNREGISTER_UNTAGGED(array); \
+F_ARRAY *code_to_emit(CELL name)
+{
+ return untag_object(array_nth(untag_object(userenv[name]),0));
+}
+
+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)); \
}
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_quot_xt",(CELL)code);
+
quot->code = code;
quot->xt = (XT)(code + 1);
quot->compiledp = T;
}
-void jit_compile(F_QUOTATION *quot)
+/* Might GC */
+void jit_compile(CELL quot)
{
- F_ARRAY *array = untag_object(quot->array);
+ if(untag_quotation(quot)->compiledp != F)
+ return;
+
+ CELL code_format = compiled_code_format();
+
+ REGISTER_ROOT(quot);
- REGISTER_UNTAGGED(quot);
+ CELL array = untag_quotation(quot)->array;
+ REGISTER_ROOT(array);
- REGISTER_UNTAGGED(array);
- GROWABLE_ARRAY(result);
- UNREGISTER_UNTAGGED(array);
+ GROWABLE_ARRAY(code);
+ 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);
+ GROWABLE_ADD(words,quot);
+
+ bool stack_frame = jit_stack_frame_p(untag_object(array));
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))
{
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);
+ EMIT(JIT_EPILOG,0);
- if(primitive_p)
- EMIT(JIT_WORD_PRIMITIVE_JUMP);
+ EMIT(JIT_WORD_JUMP,words_count - 1);
- EMIT(JIT_WORD_JUMP);
tail_call = true;
}
else
- {
- if(primitive_p)
- EMIT(JIT_WORD_PRIMITIVE_CALL);
-
- EMIT(JIT_WORD_CALL);
- }
+ EMIT(JIT_WORD_CALL,words_count - 1);
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 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(array,i))
+ if(jit_fast_if_p(untag_object(array),i))
{
- i += 2;
+ 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);
- if(i == length - 1)
- {
- if(stack_frame)
- EMIT(JIT_EPILOG);
- EMIT(JIT_IF_JUMP);
- tail_call = true;
- }
- else
- EMIT(JIT_IF_CALL);
+ i += 2;
+ 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;
}
}
if(!tail_call)
{
if(stack_frame)
- EMIT(JIT_EPILOG);
+ EMIT(JIT_EPILOG,0);
+
+ EMIT(JIT_RETURN,0);
+ }
+
+ GROWABLE_TRIM(code);
+ GROWABLE_TRIM(relocation);
+ GROWABLE_TRIM(literals);
+ GROWABLE_TRIM(words);
+
+ F_COMPILED *compiled = add_compiled_block(
+ QUOTATION_TYPE,
+ untag_object(code),
+ NULL,
+ untag_object(relocation),
+ untag_object(words),
+ untag_object(literals));
+
+ /* 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);
+ UNREGISTER_ROOT(code);
+ UNREGISTER_ROOT(array);
+ UNREGISTER_ROOT(quot);
+}
- EMIT(JIT_RETURN);
+/* 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; \
}
- GROWABLE_TRIM(result);
+F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
+{
+ CELL code_format = compiled_code_format();
- UNREGISTER_UNTAGGED(quot);
- REGISTER_UNTAGGED(quot);
+ CELL array = untag_quotation(quot)->array;
- REGISTER_UNTAGGED(result);
- F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot));
- UNREGISTER_UNTAGGED(result);
+ bool stack_frame = jit_stack_frame_p(untag_object(array));
- F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,result,NULL,NULL,NULL,literals);
- iterate_code_heap_step(compiled,finalize_code_block);
+ if(stack_frame)
+ COUNT(JIT_PROLOG,0)
- UNREGISTER_UNTAGGED(quot);
- set_quot_xt(quot,compiled);
-}
+ CELL i;
+ CELL length = array_capacity(untag_object(array));
+ bool tail_call = false;
-F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack)
-{
- stack_chain->callstack_top = stack;
- REGISTER_ROOT(tagged);
- jit_compile(untag_quotation(tagged));
- UNREGISTER_ROOT(tagged);
- return tagged;
-}
+ for(i = 0; i < length; i++)
+ {
+ CELL obj = array_nth(untag_object(array),i);
+ F_WORD *word;
-XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset)
-{
- if(offset != -1)
- critical_error("Not yet implemented",0);
+ switch(type_of(obj))
+ {
+ case WORD_TYPE:
+ word = untag_object(obj);
- CELL xt = 0;
+ if(i == length - 1)
+ {
+ if(stack_frame)
+ COUNT(JIT_EPILOG,i);
- xt += array_capacity(untag_array(userenv[JIT_SETUP]));
+ COUNT(JIT_WORD_JUMP,i)
- bool stack_frame = jit_stack_frame_p(untag_array(quot->array));
- if(stack_frame)
- xt += array_capacity(untag_array(userenv[JIT_PROLOG]));
+ tail_call = true;
+ }
+ else
+ 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++;
- xt *= compiled_code_format();
+ tail_call = true;
+ 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)
- return quot->xt + xt;
+ 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;
+ REGISTER_ROOT(quot);
+ jit_compile(quot);
+ UNREGISTER_ROOT(quot);
+ return quot;
}
DEFINE_PRIMITIVE(curry)
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;
-}
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);
+F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
void uncurry(CELL obj);
DECLARE_PRIMITIVE(curry);
DECLARE_PRIMITIVE(array_to_quotation);
DECLARE_PRIMITIVE(quotation_xt);
DECLARE_PRIMITIVE(uncurry);
-DECLARE_PRIMITIVE(strip_compiled_quotations);
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;
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);
rs = array_to_stack(untag_array(dpop()),rs_bot);
}
-XT default_word_xt(F_WORD *word)
-{
- if(word->def == T)
- return dosym;
- else if(type_of(word->def) == QUOTATION_TYPE)
- {
- if(profiling_p())
- return docol_profiling;
- else
- return docol;
- }
- else if(type_of(word->def) == FIXNUM_TYPE)
- return primitives[to_fixnum(word->def)];
- else
- return undefined;
-}
-
DEFINE_PRIMITIVE(getenv)
{
F_FIXNUM e = untag_fixnum_fast(dpeek());
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 */
/* Used by the JIT compiler */
JIT_CODE_FORMAT = 22,
- JIT_SETUP,
JIT_PROLOG,
- JIT_WORD_PRIMITIVE_JUMP,
- JIT_WORD_PRIMITIVE_CALL,
+ JIT_PRIMITIVE_WORD,
+ JIT_PRIMITIVE,
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,
JIT_RETURN,
+ JIT_PROFILING,
- /* Profiler support */
- PROFILING_ENV = 38, /* is the profiler on? */
- PROFILER_PROLOGUE_ENV /* length of optimizing compiler's profiler prologue */
+ UNDEFINED_ENV = 37, /* default quotation for undefined words */
+ STAGE2_ENV = 39 /* have we bootstrapped? */
} F_ENVTYPE;
#define FIRST_SAVE_ENV BOOT_ENV
CELL catchstack_save;
CELL current_callback_save;
- /* saved extra_roots pointer on entry to callback */
- CELL extra_roots;
-
struct _F_CONTEXT *next;
} F_CONTEXT;
DECLARE_PRIMITIVE(from_r);
DECLARE_PRIMITIVE(datastack);
DECLARE_PRIMITIVE(retainstack);
-
-XT default_word_xt(F_WORD *word);
-
DECLARE_PRIMITIVE(execute);
DECLARE_PRIMITIVE(call);
DECLARE_PRIMITIVE(getenv);
DECLARE_PRIMITIVE(class_hash);
DECLARE_PRIMITIVE(slot);
DECLARE_PRIMITIVE(set_slot);
+
+bool stage2;
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);
{
int i;
F_ARRAY* new_array;
-
+
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
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);
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)
{
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);
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; \
dpush(tag_object(hash));
}
-/* <word> ( name vocabulary -- word ) */
F_WORD *allot_word(CELL vocab, CELL name)
{
REGISTER_ROOT(vocab);
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;
- word->def = F;
+ word->def = userenv[UNDEFINED_ENV];
word->props = F;
word->counter = tag_fixnum(0);
word->compiledp = F;
- word->xt = 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;
}
+/* <word> ( name vocabulary -- word ) */
DEFINE_PRIMITIVE(word)
{
CELL vocab = dpop();
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);
-}
-
+/* word-xt ( word -- xt ) */
DEFINE_PRIMITIVE(word_xt)
{
F_WORD *word = untag_word(dpeek());
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);
F_WORD *allot_word(CELL vocab, CELL name);
DECLARE_PRIMITIVE(word);
-DECLARE_PRIMITIVE(update_xt);
DECLARE_PRIMITIVE(word_xt);
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)
-{
- 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 = growable_add(result,elt,&result##_count)
-
-INLINE F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
-{
- REGISTER_UNTAGGED(elts);
+ result = tag_object(growable_add(untag_object(result),elt,&result##_count))
- 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 = 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))
projects / factor.git / commitdiff