vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
+ vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/image.o \
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<
-
+
.PHONY: factor
classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
-io.encodings.string libc splitting math.parser
+io.encodings.string libc splitting math.parser memory
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
enable-compiler
+! Push all tuple layouts to tenured space to improve method caching
+gc
+
: compile-unoptimized ( words -- )
[ optimized>> not ] filter compile ;
USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences sequences.private strings sbufs
-vectors words quotations assocs system layouts splitting
-grouping growable classes classes.builtin classes.tuple
-classes.tuple.private words.private vocabs
-vocabs.loader source-files definitions debugger
-quotations.private sequences.private combinators
-math.order math.private accessors
-slots.private compiler.units fry ;
+prettyprint sequences sequences.private strings sbufs vectors words
+quotations assocs system layouts splitting grouping growable classes
+classes.builtin classes.tuple classes.tuple.private
+vocabs vocabs.loader source-files definitions debugger
+quotations.private sequences.private combinators math.order
+math.private accessors slots.private compiler.units compiler.constants
+fry ;
IN: bootstrap.image
: arch ( os cpu -- arch )
SYMBOL: sub-primitives
-: make-jit ( quot rc rt offset -- quad )
- [ [ call( -- ) ] { } make ] 3dip 4array ;
+SYMBOL: jit-define-rc
+SYMBOL: jit-define-rt
+SYMBOL: jit-define-offset
-: jit-define ( quot rc rt offset name -- )
+: compute-offset ( -- offset )
+ building get length jit-define-rc get rc-absolute-cell = cell 4 ? - ;
+
+: jit-rel ( rc rt -- )
+ jit-define-rt set
+ jit-define-rc set
+ compute-offset jit-define-offset set ;
+
+: make-jit ( quot -- quad )
+ [
+ call( -- )
+ jit-define-rc get
+ jit-define-rt get
+ jit-define-offset get 3array
+ ] { } make prefix ;
+
+: jit-define ( quot name -- )
[ make-jit ] dip set ;
-: define-sub-primitive ( quot rc rt offset word -- )
+: define-sub-primitive ( quot word -- )
[ make-jit ] dip sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
+SYMBOL: jit-execute-word
+SYMBOL: jit-execute-jump
+SYMBOL: jit-execute-call
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
{ jit-2dip 47 }
{ jit-3dip-word 48 }
{ jit-3dip 49 }
+ { jit-execute-word 50 }
+ { jit-execute-jump 51 }
+ { jit-execute-call 52 }
{ undefined-quot 60 }
} ; inline
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
+ \ (execute) jit-execute-word set
[ undefined ] undefined-quot set
{
jit-code-format
jit-2dip
jit-3dip-word
jit-3dip
+ jit-execute-word
+ jit-execute-jump
+ jit-execute-call
jit-epilog
jit-return
jit-profiling
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
-system combinators math.bitwise words.private math.order
+system combinators math.bitwise math.order
accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- [ label>> ] [ class>> ] bi compiled-offset 4 - rot
+ [ class>> ] [ label>> ] bi compiled-offset 4 - swap
3array label-table get push ;
TUPLE: rel-fixup class type ;
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
compiler.errors compiler.tree.builder compiler.tree.optimizer
compiler.units help.markup help.syntax io parser quotations
-sequences words words.private ;
+sequences words ;
IN: compiler
HELP: enable-compiler
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io source-files.errors
-stack-checker stack-checker.state stack-checker.inlining
-stack-checker.errors combinators.short-circuit compiler.errors
-compiler.units compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
-compiler.cfg.two-operand compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
+generic.single combinators deques search-deques macros io
+source-files.errors stack-checker stack-checker.state
+stack-checker.inlining stack-checker.errors combinators.short-circuit
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
+compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
SYMBOL: compiled
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
#! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
} 1|| not ;
: queue-compile ( word -- )
- dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
+ dup compile? [ compile-queue get push-front ] [ drop ] if ;
: recompile-callers? ( word -- ? )
changed-effects get key? ;
H{ } clone generic-dependencies set
clear-compiler-error ;
+GENERIC: no-compile? ( word -- ? )
+
+M: word no-compile? "no-compile" word-prop ;
+
+M: method-body no-compile? "method-generic" word-prop no-compile? ;
+
+M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
+
: ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
{
[ macro? ]
[ inline? ]
+ [ no-compile? ]
[ "special" word-prop ]
- [ "no-compile" word-prop ]
} 1||
] [
{
2bi
] if ;
+: optimize? ( word -- ? )
+ { [ contains-breakpoints? ] [ single-generic? ] } 1|| not ;
+
: frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
- dup contains-breakpoints? [ dup def>> deoptimize-with ] [
- [ build-tree ] [ deoptimize ] recover optimize-tree
- ] if ;
+ dup optimize?
+ [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
+ [ dup def>> deoptimize-with ]
+ if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
- [ queue-compile ] each
+ [
+ [ queue-compile ]
+ [ subwords [ compile-dependency ] each ] bi
+ ] each
compile-queue get compile-loop
compiled get >alist
] with-scope ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard generic.math
+math.partial-dispatch generic generic.standard generic.single generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart hints
locals
! See http://factorcode.org/license.txt for BSD license.\r
USING: bootstrap.image.private kernel kernel.private namespaces\r
system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
-compiler.constants math math.private layouts words words.private\r
+compiler.constants math math.private layouts words\r
vocabs slots.private locals.backend ;\r
IN: bootstrap.ppc\r
\r
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
11 6 profile-count-offset LWZ\r
11 11 1 tag-fixnum ADDI\r
11 6 profile-count-offset STW\r
11 11 compiled-header-size ADDI\r
11 MTCTR\r
BCTR\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define\r
+] jit-profiling jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
0 MFLR\r
1 1 stack-frame SUBI\r
6 1 xt-save STW\r
stack-frame 6 LI\r
6 1 next-save STW\r
0 1 lr-save stack-frame + STW\r
-] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define\r
+] jit-prolog jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
6 ds-reg 4 STWU\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define\r
+] jit-push-immediate jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel\r
7 6 0 LWZ\r
1 7 0 STW\r
-] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define\r
+] jit-save-stack jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel\r
6 MTCTR\r
BCTR\r
-] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define\r
+] jit-primitive jit-define\r
\r
-[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define\r
+[ 0 BL rc-relative-ppc-3 rt-xt jit-rel ] jit-word-call jit-define\r
\r
-[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
+[ 0 B rc-relative-ppc-3 rt-xt ] jit-word-jump jit-define\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
0 3 \ f tag-number CMPI\r
2 BEQ\r
- 0 B\r
-] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define\r
+ 0 B rc-relative-ppc-3 rt-xt jit-rel\r
+] jit-if-1 jit-define\r
\r
[\r
- 0 B\r
-] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define\r
+ 0 B rc-relative-ppc-3 rt-xt jit-rel\r
+] jit-if-2 jit-define\r
\r
: jit-jump-quot ( -- )\r
4 3 quot-xt-offset LWZ\r
BCTR ;\r
\r
[\r
- 0 3 LOAD32\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
6 ds-reg 0 LWZ\r
6 6 1 SRAWI\r
3 3 6 ADD\r
3 3 array-start-offset LWZ\r
ds-reg dup 4 SUBI\r
jit-jump-quot\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define\r
+] jit-dispatch jit-define\r
\r
: jit->r ( -- )\r
4 ds-reg 0 LWZ\r
\r
[\r
jit->r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt\r
jit-r>\r
-] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define\r
+] jit-dip jit-define\r
\r
[\r
jit-2>r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt\r
jit-2r>\r
-] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define\r
+] jit-2dip jit-define\r
\r
[\r
jit-3>r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt\r
jit-3r>\r
-] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define\r
+] jit-3dip jit-define\r
\r
[\r
0 1 lr-save stack-frame + LWZ\r
1 1 stack-frame ADDI\r
0 MTLR\r
-] f f f jit-epilog jit-define\r
+] jit-epilog jit-define\r
\r
-[ BLR ] f f f jit-return jit-define\r
+[ BLR ] jit-return jit-define\r
\r
! Sub-primitives\r
\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
jit-jump-quot\r
-] f f f \ (call) define-sub-primitive\r
+] \ (call) define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 3 word-xt-offset LWZ\r
4 MTCTR\r
BCTR\r
-] f f f \ (execute) define-sub-primitive\r
+] \ (execute) define-sub-primitive\r
\r
! Objects\r
[\r
3 3 tag-mask get ANDI\r
3 3 tag-bits get SLWI\r
3 ds-reg 0 STW\r
-] f f f \ tag define-sub-primitive\r
+] \ tag define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 4 0 0 31 tag-bits get - RLWINM\r
4 3 3 LWZX\r
3 ds-reg 0 STW\r
-] f f f \ slot define-sub-primitive\r
+] \ slot define-sub-primitive\r
\r
! Shufflers\r
[\r
ds-reg dup 4 SUBI\r
-] f f f \ drop define-sub-primitive\r
+] \ drop define-sub-primitive\r
\r
[\r
ds-reg dup 8 SUBI\r
-] f f f \ 2drop define-sub-primitive\r
+] \ 2drop define-sub-primitive\r
\r
[\r
ds-reg dup 12 SUBI\r
-] f f f \ 3drop define-sub-primitive\r
+] \ 3drop define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ dup define-sub-primitive\r
+] \ dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 8 ADDI\r
3 ds-reg 0 STW\r
4 ds-reg -4 STW\r
-] f f f \ 2dup define-sub-primitive\r
+] \ 2dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 0 STW\r
4 ds-reg -4 STW\r
5 ds-reg -8 STW\r
-] f f f \ 3dup define-sub-primitive\r
+] \ 3dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
3 ds-reg 0 STW\r
-] f f f \ nip define-sub-primitive\r
+] \ nip define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 8 SUBI\r
3 ds-reg 0 STW\r
-] f f f \ 2nip define-sub-primitive\r
+] \ 2nip define-sub-primitive\r
\r
[\r
3 ds-reg -4 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ over define-sub-primitive\r
+] \ over define-sub-primitive\r
\r
[\r
3 ds-reg -8 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ pick define-sub-primitive\r
+] \ pick define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZ\r
4 ds-reg 0 STW\r
3 ds-reg 4 STWU\r
-] f f f \ dupd define-sub-primitive\r
+] \ dupd define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 4 STWU\r
4 ds-reg -4 STW\r
3 ds-reg -8 STW\r
-] f f f \ tuck define-sub-primitive\r
+] \ tuck define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZ\r
3 ds-reg -4 STW\r
4 ds-reg 0 STW\r
-] f f f \ swap define-sub-primitive\r
+] \ swap define-sub-primitive\r
\r
[\r
3 ds-reg -4 LWZ\r
4 ds-reg -8 LWZ\r
3 ds-reg -8 STW\r
4 ds-reg -4 STW\r
-] f f f \ swapd define-sub-primitive\r
+] \ swapd define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -8 STW\r
3 ds-reg -4 STW\r
5 ds-reg 0 STW\r
-] f f f \ rot define-sub-primitive\r
+] \ rot define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg -8 STW\r
5 ds-reg -4 STW\r
4 ds-reg 0 STW\r
-] f f f \ -rot define-sub-primitive\r
+] \ -rot define-sub-primitive\r
\r
-[ jit->r ] f f f \ load-local define-sub-primitive\r
+[ jit->r ] \ load-local define-sub-primitive\r
\r
! Comparisons\r
: jit-compare ( insn -- )\r
2 BNE\r
1 tag-fixnum 4 LI\r
4 ds-reg 0 STW\r
-] f f f \ both-fixnums? define-sub-primitive\r
+] \ both-fixnums? define-sub-primitive\r
\r
: jit-math ( insn -- )\r
3 ds-reg 0 LWZ\r
[ 5 3 4 ] dip execute( dst src1 src2 -- )\r
5 ds-reg 0 STW ;\r
\r
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive\r
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive\r
\r
-[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive\r
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 4 tag-bits get SRAWI\r
5 3 4 MULLW\r
5 ds-reg 0 STW\r
-] f f f \ fixnum*fast define-sub-primitive\r
+] \ fixnum*fast define-sub-primitive\r
\r
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive\r
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive\r
\r
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive\r
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive\r
\r
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive\r
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 3 NOT\r
3 3 tag-mask get XORI\r
3 ds-reg 0 STW\r
-] f f f \ fixnum-bitnot define-sub-primitive\r
+] \ fixnum-bitnot define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
2 BGT\r
5 7 MR\r
5 ds-reg 0 STW\r
-] f f f \ fixnum-shift-fast define-sub-primitive\r
+] \ fixnum-shift-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
6 5 3 MULLW\r
7 6 4 SUBF\r
7 ds-reg 0 STW\r
-] f f f \ fixnum-mod define-sub-primitive\r
+] \ fixnum-mod define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
5 4 3 DIVW\r
5 5 tag-bits get SLWI\r
5 ds-reg 0 STW\r
-] f f f \ fixnum/i-fast define-sub-primitive\r
+] \ fixnum/i-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
5 5 tag-bits get SLWI\r
5 ds-reg -4 STW\r
7 ds-reg 0 STW\r
-] f f f \ fixnum/mod-fast define-sub-primitive\r
+] \ fixnum/mod-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 3 1 SRAWI\r
rs-reg 3 3 LWZX\r
3 ds-reg 0 STW\r
-] f f f \ get-local define-sub-primitive\r
+] \ get-local define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg ds-reg 4 SUBI\r
3 3 1 SRAWI\r
rs-reg 3 rs-reg SUBF\r
-] f f f \ drop-locals define-sub-primitive\r
+] \ drop-locals define-sub-primitive\r
\r
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
: rex-length ( -- n ) 0 ;
[
- temp0 0 [] MOV ! load stack_chain
- temp0 [] stack-reg MOV ! save stack pointer
-] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+ ! load stack_chain
+ temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+] jit-save-stack jit-define
[
- (JMP) drop
-] rc-relative rt-primitive 1 jit-primitive jit-define
+ (JMP) drop rc-relative rt-primitive jit-rel
+] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call
: rex-length ( -- n ) 1 ;
[
- temp0 0 MOV ! load stack_chain
+ ! load stack_chain
+ temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
- temp0 [] stack-reg MOV ! save stack pointer
-] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+] jit-save-stack jit-define
[
- temp1 0 MOV ! load XT
- temp1 JMP ! go
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+ ! load XT
+ temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
+ ! go
+ temp1 JMP
+] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler layouts compiler.units math
math.private compiler.constants vocabs slots.private words
-words.private locals.backend ;
+locals.backend ;
IN: bootstrap.x86
big-endian off
[
! Load word
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! Bump profiling counter
temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
temp0 compiled-header-size ADD
! Jump to XT
temp0 JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
+] jit-profiling jit-define
[
! load XT
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size
stack-frame-size PUSH
! push XT
temp0 PUSH
! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
+] jit-prolog jit-define
[
! load literal
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! increment datastack pointer
ds-reg bootstrap-cell ADD
! store literal on datastack
ds-reg [] temp0 MOV
-] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
+] jit-push-immediate jit-define
[
- f JMP
-] rc-relative rt-xt 1 jit-word-jump jit-define
+ f JMP rc-relative rt-xt jit-rel
+] jit-word-jump jit-define
[
- f CALL
-] rc-relative rt-xt 1 jit-word-call jit-define
+ f CALL rc-relative rt-xt jit-rel
+] jit-word-call jit-define
[
! load boolean
! compare boolean with f
temp0 \ f tag-number CMP
! jump to true branch if not equal
- f JNE
-] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
+ f JNE rc-relative rt-xt jit-rel
+] jit-if-1 jit-define
[
! jump to false branch if equal
- f JMP
-] rc-relative rt-xt 1 jit-if-2 jit-define
+ f JMP rc-relative rt-xt jit-rel
+] jit-if-2 jit-define
[
! load dispatch table
- temp1 0 MOV
+ temp1 0 MOV rc-absolute-cell rt-immediate jit-rel
! load index
temp0 ds-reg [] MOV
! turn it into an array offset
! execute branch. the quot must be in arg, since it might
! not be compiled yet
arg quot-xt-offset [+] JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
+] jit-dispatch jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
[
jit->r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-r>
-] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
+] jit-dip jit-define
[
jit-2>r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-2r>
-] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
+] jit-2dip jit-define
[
jit-3>r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-3r>
-] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
+] jit-3dip jit-define
+
+: prepare-(execute) ( -- operand )
+ ! load from stack
+ temp0 ds-reg [] MOV
+ ! pop stack
+ ds-reg bootstrap-cell SUB
+ ! execute word
+ temp0 word-xt-offset [+] ;
+
+[ prepare-(execute) JMP ] jit-execute-jump jit-define
+
+[ prepare-(execute) CALL ] jit-execute-call jit-define
[
! unwind stack frame
stack-reg stack-frame-size bootstrap-cell - ADD
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
-[ 0 RET ] f f f jit-return jit-define
+[ 0 RET ] jit-return jit-define
! Sub-primitives
ds-reg bootstrap-cell SUB
! call quotation
arg quot-xt-offset [+] JMP
-] f f f \ (call) define-sub-primitive
-
-[
- ! load from stack
- temp0 ds-reg [] MOV
- ! pop stack
- ds-reg bootstrap-cell SUB
- ! execute word
- temp0 word-xt-offset [+] JMP
-] f f f \ (execute) define-sub-primitive
+] \ (call) define-sub-primitive
! Objects
[
temp0 tag-bits get SHL
! push to stack
ds-reg [] temp0 MOV
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
[
! load slot number
temp0 temp1 temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
! Shufflers
[
ds-reg bootstrap-cell SUB
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
[
ds-reg 2 bootstrap-cells SUB
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
[
ds-reg 3 bootstrap-cells SUB
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells ADD
ds-reg [] temp0 MOV
ds-reg bootstrap-cell neg [+] temp1 MOV
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp3 MOV
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
ds-reg [] temp0 MOV
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells SUB
ds-reg [] temp0 MOV
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
[
temp0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
[
temp0 ds-reg -2 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg [] temp1 MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
[
temp0 ds-reg [] MOV
temp1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] temp0 MOV
ds-reg [] temp1 MOV
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
[
temp0 ds-reg -1 bootstrap-cells [+] MOV
temp1 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg -2 bootstrap-cells [+] temp1 MOV
ds-reg -1 bootstrap-cells [+] temp0 MOV
ds-reg [] temp3 MOV
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp3 MOV
ds-reg [] temp1 MOV
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
! load t
- temp3 0 MOV
+ temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
! load f
temp1 \ f tag-number MOV
! load first value
ds-reg [] temp1 MOV ;
: define-jit-compare ( insn word -- )
- [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
- define-sub-primitive ;
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;
\ CMOVE \ eq? define-jit-compare
\ CMOVGE \ fixnum>= define-jit-compare
! compute result
[ ds-reg [] temp0 ] dip execute( dst src -- ) ;
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
-[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive
[
! load second input
temp0 temp1 IMUL2
! push result
ds-reg [] temp1 MOV
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
[
! complement
ds-reg [] NOT
! clear tag bits
ds-reg [] tag-mask get XOR
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
[
! load shift count
temp1 temp3 CMOVGE
! push to stack
ds-reg [] temp1 MOV
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod ( -- )
! load second parameter
ds-reg bootstrap-cell SUB
! push to stack
ds-reg [] mod-arg MOV
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
[
jit-fixnum-/mod
div-arg tag-bits get SHL
! push to stack
ds-reg [] div-arg MOV
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
[
jit-fixnum-/mod
! push to stack
ds-reg [] mod-arg MOV
ds-reg bootstrap-cell neg [+] div-arg MOV
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
[
temp0 ds-reg [] MOV
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE
ds-reg [] temp0 MOV
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
[
! load local number
temp0 rs-reg temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
[
! load local count
fixnum>slot@
! decrement retain stack pointer
rs-reg temp0 SUB
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations io.files.private listener
+help generic.single continuations io.files.private listener
alien.libraries ;
IN: debugger
io.pathnames vectors words system splitting math.parser
classes.mixin classes.tuple continuations continuations.private
combinators generic.math classes.builtin classes compiler.units
-generic.standard vocabs init kernel.private io.encodings
+generic.standard generic.single vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting math
-math.parser generic generic.standard generic.standard.engines classes
+math.parser generic generic.single generic.standard classes
hashtables namespaces ;
IN: hints
t specialize-method? set-global
+: method-declaration ( method -- quot )
+ [ "method-generic" word-prop dispatch# object <array> ]
+ [ "method-class" word-prop ]
+ bi prefix [ declare ] curry [ ] like ;
+
: specialize-method ( quot method -- quot' )
- [
- specialize-method? get [
- [ "method-class" word-prop ] [ "method-generic" word-prop ] bi
- method-declaration prepend
- ] [ drop ] if
- ]
+ [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
[ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
-classes.intersection classes.mixin classes.predicate
-classes.singleton classes.tuple classes.union combinators
-definitions effects generic generic.standard io io.pathnames
+classes.intersection classes.mixin classes.predicate classes.singleton
+classes.tuple classes.union combinators definitions effects generic
+generic.single generic.standard generic.hook io io.pathnames
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
-prettyprint.sections sequences sets sorting strings summary
-words words.symbol words.constant words.alias ;
+prettyprint.sections sequences sets sorting strings summary words
+words.symbol words.constant words.alias ;
IN: see
GENERIC: synopsis* ( defspec -- )
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry arrays generic io io.streams.string kernel math
-namespaces parser sequences strings vectors words quotations
-effects classes continuations assocs combinators
-compiler.errors accessors math.order definitions sets
-generic.standard.engines.tuple hints macros stack-checker.state
+USING: fry arrays generic io io.streams.string kernel math namespaces
+parser sequences strings vectors words quotations effects classes
+continuations assocs combinators compiler.errors accessors math.order
+definitions sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
IN: stack-checker.backend
sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
-words.private assocs summary compiler.units system.private
-combinators locals locals.backend locals.types words.private
+assocs summary compiler.units system.private
+combinators locals locals.backend locals.types
quotations.private combinators.private stack-checker.values
+generic.single generic.single.private
alien.libraries
stack-checker.alien
stack-checker.state
! More words not to compile
\ call t "no-compile" set-word-prop
-\ call subwords [ t "no-compile" set-word-prop ] each
-
\ execute t "no-compile" set-word-prop
-\ execute subwords [ t "no-compile" set-word-prop ] each
-
-\ effective-method t "no-compile" set-word-prop
-\ effective-method subwords [ t "no-compile" set-word-prop ] each
-
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
\ gc-stats { } { array } define-primitive
\ jit-compile { quotation } { } define-primitive
+
+\ lookup-method { object array } { word } define-primitive
\ No newline at end of file
] 1 define-transform
\ boa t "no-compile" set-word-prop
-M\ tuple-class boa t "no-compile" set-word-prop
\ new [
dup tuple-class? [
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
-generic generic.standard definitions make sbufs tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref ;
IN: tools.continuations
<PRIVATE
: (step-into-execute) ( word -- )
{
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
- { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup single-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup uses \ suspend swap member? ] [ execute break ] }
{ [ dup primitive? ] [ execute break ] }
[ def>> (step-into-quot) ]
USING: words assocs definitions io io.pathnames io.styles kernel
prettyprint sorting see sets sequences arrays hashtables help.crossref
help.topics help.markup quotations accessors source-files namespaces
-graphs vocabs generic generic.standard.engines.tuple threads
-compiler.units init ;
+graphs vocabs generic generic.single threads compiler.units init ;
IN: tools.crossref
SYMBOL: crossref
M: default-method irrelevant? drop t ;
-M: engine-word irrelevant? drop t ;
+M: predicate-engine irrelevant? drop t ;
PRIVATE>
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
-summary layouts vocabs.loader prettyprint.config prettyprint
-debugger io.streams.c io.files io.files.temp io.pathnames
-io.directories io.directories.hierarchy io.backend quotations
-io.launcher words.private tools.deploy.config
-tools.deploy.config.editor bootstrap.image io.encodings.utf8
-destructors accessors hashtables ;
+summary layouts vocabs.loader prettyprint.config prettyprint debugger
+io.streams.c io.files io.files.temp io.pathnames io.directories
+io.directories.hierarchy io.backend quotations io.launcher
+tools.deploy.config tools.deploy.config.editor bootstrap.image
+io.encodings.utf8 destructors accessors hashtables ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name -- vm )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.backend io.streams.c init fry
namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words words.private memory kernel.private
+sequences words memory kernel.private
continuations io vocabs.loader system strings sets
vectors quotations byte-arrays sorting compiler.units
definitions generic generic.standard tools.deploy.config ;
ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
ui.tools.inspector ui.gadgets.status-bar ui.operations
ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
-ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener
+ui.gadgets.labels ui.baseline-alignment ui.images
compiler.errors tools.errors tools.errors.model ;
IN: ui.tools.error-list
USING: accessors arrays assocs calendar colors colors.constants
documents documents.elements fry kernel words sets splitting math
math.vectors models.delay models.arrow combinators.short-circuit
-parser present sequences tools.completion help.vocabs generic
-generic.standard.engines.tuple fonts definitions.icons ui.images
-ui.commands ui.operations ui.gadgets ui.gadgets.editors
-ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables
-ui.gadgets.tracks ui.gadgets.labeled
+parser present sequences tools.completion help.vocabs generic fonts
+definitions.icons ui.images ui.commands ui.operations ui.gadgets
+ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled
ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid
ui.tools.listener.history combinators vocabs ui.tools.listener.popups ;
IN: ui.tools.listener.completion
M: method-body completion-string method-completion-string ;
-M: engine-word completion-string method-completion-string ;
-
GENERIC# accept-completion-hook 1 ( item popup -- )
: insert-completion ( item popup -- )
"classes.predicate"
"compiler.units"
"continuations.private"
+ "generic.single.private"
"growable"
"hashtables"
"hashtables.private"
"threads.private"
"tools.profiler.private"
"words"
- "words.private"
"vectors"
"vectors.private"
} [ create-vocab drop ] each
[ create dup 1quotation ] dip define-declared ;
{
- { "(execute)" "words.private" (( word -- )) }
+ { "(execute)" "kernel.private" (( word -- )) }
{ "(call)" "kernel.private" (( quot -- )) }
{ "both-fixnums?" "math.private" (( x y -- ? )) }
{ "fixnum+fast" "math.private" (( x y -- z )) }
{ "jit-compile" "quotations" (( quot -- )) }
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
+ { "lookup-method" "generic.single.private" (( object methods method-cache -- method )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
-USING: definitions generic kernel kernel.private math
-math.constants parser sequences tools.test words assocs
-namespaces quotations sequences.private classes continuations
-generic.standard effects classes.tuple classes.tuple.private
-arrays vectors strings compiler.units accessors classes.algebra
-calendar prettyprint io.streams.string splitting summary
-columns math.order classes.private slots slots.private eval see
-words.symbol compiler.errors ;
+USING: definitions generic kernel kernel.private math math.constants
+parser sequences tools.test words assocs namespaces quotations
+sequences.private classes continuations generic.single
+generic.standard effects classes.tuple classes.tuple.private arrays
+vectors strings compiler.units accessors classes.algebra calendar
+prettyprint io.streams.string splitting summary columns math.order
+classes.private slots slots.private eval see words.symbol
+compiler.errors ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
-generic.standard generic.math combinators prettyprint effects ;
+generic.single generic.standard generic.hook generic.math
+combinators prettyprint effects ;
IN: generic
ARTICLE: "method-order" "Method precedence"
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: generic generic.single generic.standard help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.hook
+
+HELP: hook-combination
+{ $class-description
+ "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
+} ;
+
+{ standard-combination hook-combination } related-words
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors definitions generic generic.single kernel
+namespaces words ;
+IN: generic.hook
+
+TUPLE: hook-combination < single-combination var ;
+
+C: <hook-combination> hook-combination
+
+PREDICATE: hook-generic < generic
+ "combination" word-prop hook-combination? ;
+
+M: hook-combination picker
+ combination get var>> [ get ] curry ;
+
+M: hook-combination dispatch# drop 0 ;
+
+M: hook-generic definer drop \ HOOK: f ;
+
+M: hook-generic effective-method
+ [ "combination" word-prop var>> get ] keep (effective-method) ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: generic help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.single
+
+HELP: no-method
+{ $values { "object" "an object" } { "generic" "a generic word" } }
+{ $description "Throws a " { $link no-method } " error." }
+{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: string error-test print ;"
+ ""
+ "M: integer error-test number>string call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+ $nl
+ "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+ { $code "M: integer error-test number>string error-test ;" }
+} ;
\ No newline at end of file
--- /dev/null
+IN: generic.single.tests
+USING: tools.test math math.functions math.constants generic.standard
+generic.single strings sequences arrays kernel accessors words
+specialized-arrays.double byte-arrays bit-arrays parser namespaces
+make quotations stack-checker vectors growable hashtables sbufs
+prettyprint byte-vectors bit-vectors specialized-vectors.double
+definitions generic sets graphs assocs grouping see ;
+
+GENERIC: lo-tag-test ( obj -- obj' )
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test ( obj -- obj' )
+
+M: string hi-tag-test ", in bed" append ;
+
+M: integer hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area ( shape -- n )
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter ( shape -- n )
+
+: rectangle-perimiter ( l w -- n ) + 2 * ;
+
+M: rectangle perimiter
+ [ width>> ] [ height>> ] bi
+ rectangle-perimiter ;
+
+: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+ [ width>> ]
+ [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+ rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test ( obj -- obj' )
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag ( obj -- obj )
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: double-array small-lo-tag drop "double-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+ #! Intentional mistake.
+ call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+ #! Intentional error.
+ drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey boa salary ] unit-test
+
+[ 36000 ] [ junior-manager boa salary ] unit-test
+
+[ 41000 ] [ middle-manager boa salary ] unit-test
+
+[ 51000 ] [ senior-manager boa salary ] unit-test
+
+[ 102000 ] [ executive boa salary ] unit-test
+
+[ ceo boa salary ]
+[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
+
+[ intern boa salary ]
+[ no-next-method? ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky ( obj -- seq ) [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+ T{ a } funky
+ { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+[ "an integer" ] [ 3 my-var set my-hook ] unit-test
+[ "a string" ] [ my-hook my-var set my-hook ] unit-test
+[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
+
+HOOK: call-next-hooker my-var ( -- x )
+
+M: sequence call-next-hooker "sequence" ;
+
+M: array call-next-hooker call-next-method "array " prepend ;
+
+M: vector call-next-hooker call-next-method "vector " prepend ;
+
+M: growable call-next-hooker call-next-method "growable " prepend ;
+
+[ "vector growable sequence" ] [
+ V{ } my-var [ call-next-hooker ] with-variable
+] unit-test
+
+[ t ] [
+ { } \ nth effective-method nip M\ sequence nth eq?
+] unit-test
+
+[ t ] [
+ \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.algebra
+combinators definitions generic hashtables kernel
+kernel.private layouts make math namespaces quotations
+sequences words generic.single.private effects make ;
+IN: generic.single
+
+ERROR: no-method object generic ;
+
+ERROR: inconsistent-next-method class generic ;
+
+TUPLE: single-combination ;
+
+PREDICATE: single-generic < generic
+ "combination" word-prop single-combination? ;
+
+GENERIC: dispatch# ( word -- n )
+
+M: generic dispatch# "combination" word-prop dispatch# ;
+
+SYMBOL: assumed
+SYMBOL: default
+SYMBOL: generic-word
+SYMBOL: combination
+
+: with-combination ( combination quot -- )
+ [ combination ] dip with-variable ; inline
+
+HOOK: picker combination ( -- quot )
+
+M: single-combination next-method-quot*
+ [
+ 2dup next-method dup [
+ [
+ pick "predicate" word-prop %
+ 1quotation ,
+ [ inconsistent-next-method ] 2curry ,
+ \ if ,
+ ] [ ] make picker prepend
+ ] [ 3drop f ] if
+ ] with-combination ;
+
+: (effective-method) ( obj word -- method )
+ [ [ order [ instance? ] with find-last nip ] keep method ]
+ [ "default-method" word-prop ]
+ bi or ;
+
+M: single-combination make-default-method
+ [ [ picker ] dip [ no-method ] curry append ] with-combination ;
+
+! ! ! Build an engine ! ! !
+
+: find-default ( methods -- default )
+ #! Side-effects methods.
+ [ object bootstrap-word ] dip delete-at* [
+ drop generic-word get "default-method" word-prop
+ ] unless ;
+
+! 1. Flatten methods
+TUPLE: predicate-engine methods ;
+
+: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+
+: push-method ( method specializer atomic assoc -- )
+ [
+ [ H{ } clone <predicate-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
+
+: flatten-method ( class method assoc -- )
+ [ [ flatten-class keys ] keep ] 2dip [
+ [ spin ] dip push-method
+ ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
+
+! 2. Convert methods
+: split-methods ( assoc class -- first second )
+ [ [ nip class<= not ] curry assoc-filter ]
+ [ [ nip class<= ] curry assoc-filter ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+ over [ split-methods ] 2dip pick assoc-empty?
+ [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
+
+! 2.1 Convert tuple methods
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+ [ swap dup "layout" word-prop third ] dip
+ [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+ #! Convert an assoc mapping classes to methods into an
+ #! assoc mapping echelons to assocs. The first echelon
+ #! is always there
+ H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+ echelon-sort
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+ tuple bootstrap-word
+ \ <tuple-dispatch-engine> convert-methods ;
+
+! 2.2 Convert hi-tag methods
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ \ hi-tag bootstrap-word
+ \ <hi-tag-dispatch-engine> convert-methods ;
+
+! 3 Tag methods
+TUPLE: tag-dispatch-engine methods ;
+
+C: <tag-dispatch-engine> tag-dispatch-engine
+
+: <engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <tag-dispatch-engine> ;
+
+! ! ! Compile engine ! ! !
+GENERIC: compile-engine ( engine -- obj )
+
+: compile-engines ( assoc -- assoc' )
+ [ compile-engine ] assoc-map ;
+
+: compile-engines* ( assoc -- assoc' )
+ [ over assumed [ compile-engine ] with-variable ] assoc-map ;
+
+: direct-dispatch-table ( assoc n -- table )
+ default get <array> [ <enum> swap update ] keep ;
+
+M: tag-dispatch-engine compile-engine
+ methods>> compile-engines*
+ [ [ global [ target-word ] bind tag-number ] dip ] assoc-map
+ num-tags get direct-dispatch-table ;
+
+: hi-tag-number ( class -- n ) "type" word-prop ;
+
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
+
+M: hi-tag-dispatch-engine compile-engine
+ methods>> compile-engines*
+ [ [ hi-tag-number num-tags get - ] dip ] assoc-map
+ num-hi-tags direct-dispatch-table ;
+
+: build-fast-hash ( methods -- buckets )
+ >alist V{ } clone [ hashcode 1array ] distribute-buckets
+ [ compile-engines* >alist >array ] map ;
+
+M: echelon-dispatch-engine compile-engine
+ dup n>> 0 = [
+ methods>> dup assoc-size {
+ { 0 [ drop default get ] }
+ { 1 [ >alist first second compile-engine ] }
+ } case
+ ] [
+ methods>> compile-engines* build-fast-hash
+ ] if ;
+
+M: tuple-dispatch-engine compile-engine
+ tuple assumed [
+ echelons>> compile-engines
+ dup keys supremum 1+ f <array>
+ [ <enum> swap update ] keep
+ ] with-variable ;
+
+: sort-methods ( assoc -- assoc' )
+ >alist [ keys sort-classes ] keep extract-keys ;
+
+: quote-methods ( assoc -- assoc' )
+ [ 1quotation \ drop prefix ] assoc-map ;
+
+: methods-with-default ( engine -- assoc )
+ methods>> clone default get object bootstrap-word pick set-at ;
+
+: keep-going? ( assoc -- ? )
+ assumed get swap second first class<= ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ first second { } ] }
+ { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
+ [ [ first second ] [ rest-slice ] bi ]
+ } cond ;
+
+: class-predicates ( assoc -- assoc )
+ [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
+
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
+
+: <predicate-engine-word> ( -- word )
+ generic-word get name>> "/predicate-engine" append f <word>
+ dup generic-word get "owner-generic" set-word-prop ;
+
+M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
+
+: define-predicate-engine ( alist -- word )
+ [ <predicate-engine-word> ] dip
+ [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
+
+M: predicate-engine compile-engine
+ methods-with-default
+ sort-methods
+ quote-methods
+ prune-redundant-predicates
+ class-predicates
+ [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+
+M: word compile-engine ;
+
+M: f compile-engine ;
+
+: build-decision-tree ( generic -- methods )
+ {
+ [ generic-word set ]
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
+ [
+ "methods" word-prop clone
+ [ find-default default set ]
+ [ <engine> compile-engine ] bi
+ ]
+ } cleave ;
+
+: make-empty-cache ( -- array )
+ generic-word get "methods" word-prop
+ assoc-size 2 * next-power-of-2 f <array> ;
+
+M: single-combination perform-combination
+ [
+ dup build-decision-tree
+ [ "decision-tree" set-word-prop ]
+ [
+ [
+ picker %
+ ,
+ make-empty-cache ,
+ [ lookup-method (execute) ] %
+ ] [ ] make define
+ ] 2bi
+ ] with-combination ;
\ No newline at end of file
-Slava Pestov
+Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel kernel.private namespaces quotations
-generic math sequences combinators words classes.algebra arrays
-;
-IN: generic.standard.engines
-
-SYMBOL: default
-SYMBOL: assumed
-SYMBOL: (dispatch#)
-
-GENERIC: engine>quot ( engine -- quot )
-
-: engines>quots ( assoc -- assoc' )
- [ engine>quot ] assoc-map ;
-
-: engines>quots* ( assoc -- assoc' )
- [ over assumed [ engine>quot ] with-variable ] assoc-map ;
-
-: if-small? ( assoc true false -- )
- [ dup assoc-size 4 <= ] 2dip if ; inline
-
-: linear-dispatch-quot ( alist -- quot )
- default get [ drop ] prepend swap
- [
- [ [ dup ] swap [ eq? ] curry compose ]
- [ [ drop ] prepose ]
- bi* [ ] like
- ] assoc-map
- alist>quot ;
-
-: split-methods ( assoc class -- first second )
- [ [ nip class<= not ] curry assoc-filter ]
- [ [ nip class<= ] curry assoc-filter ] 2bi ;
-
-: convert-methods ( assoc class word -- assoc' )
- over [ split-methods ] 2dip pick assoc-empty? [
- 3drop
- ] [
- [ execute ] dip pick set-at
- ] if ; inline
-
-: (picker) ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- (picker) [ dip swap ] curry ]
- } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-GENERIC: extra-values ( generic -- n )
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic.standard.engines generic namespaces kernel
-kernel.private sequences classes.algebra accessors words
-combinators assocs arrays ;
-IN: generic.standard.engines.predicate
-
-TUPLE: predicate-dispatch-engine methods ;
-
-C: <predicate-dispatch-engine> predicate-dispatch-engine
-
-: class-predicates ( assoc -- assoc )
- [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
-
-: keep-going? ( assoc -- ? )
- assumed get swap second first class<= ;
-
-: prune-redundant-predicates ( assoc -- default assoc' )
- {
- { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
- { [ dup length 1 = ] [ first second { } ] }
- { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
- [ [ first second ] [ rest-slice ] bi ]
- } cond ;
-
-: sort-methods ( assoc -- assoc' )
- >alist [ keys sort-classes ] keep extract-keys ;
-
-: methods-with-default ( engine -- assoc )
- methods>> clone default get object bootstrap-word pick set-at ;
-
-M: predicate-dispatch-engine engine>quot
- methods-with-default
- engines>quots
- sort-methods
- prune-redundant-predicates
- class-predicates
- alist>quot ;
+++ /dev/null
-Chained-conditional dispatch strategy
+++ /dev/null
-Generic word dispatch strategy implementation
+++ /dev/null
-Jump table keyed by pointer tag dispatch strategy
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes.private generic.standard.engines namespaces make
-arrays assocs sequences.private quotations kernel.private
-math slots.private math.private kernel accessors words
-layouts sorting sequences combinators ;
-IN: generic.standard.engines.tag
-
-TUPLE: lo-tag-dispatch-engine methods ;
-
-C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
-
-: direct-dispatch-quot ( alist n -- quot )
- default get <array>
- [ <enum> swap update ] keep
- [ dispatch ] curry >quotation ;
-
-: lo-tag-number ( class -- n )
- dup \ hi-tag bootstrap-word eq? [
- drop \ hi-tag tag-number
- ] [
- "type" word-prop
- ] if ;
-
-: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
-
-: tag-dispatch-test ( tag# -- quot )
- picker [ tag ] append swap [ eq? ] curry append ;
-
-: tag-dispatch-quot ( alist -- quot )
- [ default get ] dip
- [ [ tag-dispatch-test ] dip ] assoc-map
- alist>quot ;
-
-M: lo-tag-dispatch-engine engine>quot
- methods>> engines>quots*
- [ [ lo-tag-number ] dip ] assoc-map
- [
- [ sort-tags tag-dispatch-quot ]
- [ picker % [ tag ] % num-tags get direct-dispatch-quot ]
- if-small? %
- ] [ ] make ;
-
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag bootstrap-word
- \ <hi-tag-dispatch-engine> convert-methods ;
-
-: num-hi-tags ( -- n ) num-types get num-tags get - ;
-
-: hi-tag-number ( class -- n )
- "type" word-prop ;
-
-: hi-tag-quot ( -- quot )
- \ hi-tag def>> ;
-
-M: hi-tag-dispatch-engine engine>quot
- methods>> engines>quots*
- [ [ hi-tag-number ] dip ] assoc-map
- [
- picker % hi-tag-quot % [
- sort-tags linear-dispatch-quot
- ] [
- num-tags get , \ fixnum-fast ,
- [ [ num-tags get - ] dip ] assoc-map
- num-hi-tags direct-dispatch-quot
- ] if-small? %
- ] [ ] make ;
+++ /dev/null
-Tuple class dispatch strategy
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes.tuple.private hashtables assocs sorting
-accessors combinators sequences slots.private math.parser words
-effects namespaces make generic generic.standard.engines
-classes.algebra math math.private kernel.private
-quotations arrays definitions ;
-IN: generic.standard.engines.tuple
-
-: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
-
-: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
-
-: tuple-layout% ( -- )
- [ { tuple } declare 1 slot { array } declare ] % ; inline
-
-: tuple-layout-echelon% ( -- )
- [ 4 slot ] % ; inline
-
-TUPLE: echelon-dispatch-engine n methods ;
-
-C: <echelon-dispatch-engine> echelon-dispatch-engine
-
-TUPLE: trivial-tuple-dispatch-engine n methods ;
-
-C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
-
-TUPLE: tuple-dispatch-engine echelons ;
-
-: push-echelon ( class method assoc -- )
- [ swap dup "layout" word-prop third ] dip
- [ ?set-at ] change-at ;
-
-: echelon-sort ( assoc -- assoc' )
- V{ } clone [
- [
- push-echelon
- ] curry assoc-each
- ] keep sort-keys ;
-
-: <tuple-dispatch-engine> ( methods -- engine )
- echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
- \ tuple-dispatch-engine boa ;
-
-: convert-tuple-methods ( assoc -- assoc' )
- tuple bootstrap-word
- \ <tuple-dispatch-engine> convert-methods ;
-
-M: trivial-tuple-dispatch-engine engine>quot
- [ n>> ] [ methods>> ] bi dup assoc-empty? [
- 2drop default get [ drop ] prepend
- ] [
- [
- [ nth-superclass% ]
- [ engines>quots* linear-dispatch-quot % ] bi*
- ] [ ] make
- ] if ;
-
-: hash-methods ( n methods -- buckets )
- >alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ <trivial-tuple-dispatch-engine> ] with map ;
-
-: class-hash-dispatch-quot ( n methods -- quot )
- [
- \ dup ,
- [ drop nth-hashcode% ]
- [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
- ] [ ] make ;
-
-: engine-word-name ( -- string )
- generic get name>> "/tuple-dispatch-engine" append ;
-
-PREDICATE: engine-word < word
- "tuple-dispatch-generic" word-prop generic? ;
-
-M: engine-word stack-effect
- "tuple-dispatch-generic" word-prop
- [ extra-values ] [ stack-effect ] bi
- dup [
- [ in>> length + ] [ out>> ] [ terminated?>> ] tri
- effect boa
- ] [ 2drop f ] if ;
-
-M: engine-word where "tuple-dispatch-generic" word-prop where ;
-
-M: engine-word crossref? "forgotten" word-prop not ;
-
-: remember-engine ( word -- )
- generic get "engines" word-prop push ;
-
-: <engine-word> ( -- word )
- engine-word-name f <word>
- dup generic get "tuple-dispatch-generic" set-word-prop ;
-
-: define-engine-word ( quot -- word )
- [ <engine-word> dup ] dip define ;
-
-: tuple-dispatch-engine-body ( engine -- quot )
- [
- picker %
- tuple-layout%
- [ n>> ] [ methods>> ] bi
- [ <trivial-tuple-dispatch-engine> engine>quot ]
- [ class-hash-dispatch-quot ]
- if-small? %
- ] [ ] make ;
-
-M: echelon-dispatch-engine engine>quot
- dup n>> zero? [
- methods>> dup assoc-empty?
- [ drop default get ] [ values first engine>quot ] if
- ] [
- tuple-dispatch-engine-body
- ] if ;
-
-: >=-case-quot ( default alist -- quot )
- [ [ drop ] prepend ] dip
- [
- [ [ dup ] swap [ fixnum>= ] curry compose ]
- [ [ drop ] prepose ]
- bi* [ ] like
- ] assoc-map
- alist>quot ;
-
-: simplify-echelon-alist ( default alist -- default' alist' )
- dup empty? [
- dup first first 1 <= [
- nip unclip second swap
- simplify-echelon-alist
- ] when
- ] unless ;
-
-: echelon-case-quot ( alist -- quot )
- #! We don't have to test for echelon 1 since all tuple
- #! classes are at least at depth 1 in the inheritance
- #! hierarchy.
- default get swap simplify-echelon-alist
- [
- [
- picker %
- tuple-layout%
- tuple-layout-echelon%
- >=-case-quot %
- ] [ ] make
- ] unless-empty ;
-
-M: tuple-dispatch-engine engine>quot
- [
- [
- tuple assumed set
- echelons>> unclip-last
- [
- [
- engine>quot
- over 0 = [
- define-engine-word
- [ remember-engine ] [ 1quotation ] bi
- ] unless
- dup default set
- ] assoc-map
- ]
- [ first2 engine>quot 2array ] bi*
- suffix
- ] with-scope
- echelon-case-quot %
- ] [ ] make ;
-USING: generic help.markup help.syntax sequences math
+USING: generic generic.single help.markup help.syntax sequences math
math.parser effects ;
IN: generic.standard
-HELP: no-method
-{ $values { "object" "an object" } { "generic" "a generic word" } }
-{ $description "Throws a " { $link no-method } " error." }
-{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
-
HELP: standard-combination
{ $class-description
"Performs standard method combination."
}
} ;
-HELP: hook-combination
-{ $class-description
- "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
-} ;
-
HELP: define-simple-generic
{ $values { "word" "a word" } { "effect" effect } }
-{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
-
-{ standard-combination hook-combination } related-words
-
-HELP: inconsistent-next-method
-{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
-{ $examples
- "The following code throws this error:"
- { $code
- "GENERIC: error-test ( object -- )"
- ""
- "M: string error-test print ;"
- ""
- "M: integer error-test number>string call-next-method ;"
- ""
- "123 error-test"
- }
- "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
- $nl
- "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
- { $code "M: integer error-test number>string error-test ;" }
-} ;
+{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
\ No newline at end of file
+++ /dev/null
-IN: generic.standard.tests
-USING: tools.test math math.functions math.constants
-generic.standard strings sequences arrays kernel accessors words
-specialized-arrays.double byte-arrays bit-arrays parser
-namespaces make quotations stack-checker vectors growable
-hashtables sbufs prettyprint byte-vectors bit-vectors
-specialized-vectors.double definitions generic sets graphs assocs
-grouping see ;
-
-GENERIC: lo-tag-test ( obj -- obj' )
-
-M: integer lo-tag-test 3 + ;
-
-M: float lo-tag-test 4 - ;
-
-M: rational lo-tag-test 2 - ;
-
-M: complex lo-tag-test sq ;
-
-[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
-[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
-[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
-[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
-
-GENERIC: hi-tag-test ( obj -- obj' )
-
-M: string hi-tag-test ", in bed" append ;
-
-M: integer hi-tag-test 3 + ;
-
-M: array hi-tag-test [ hi-tag-test ] map ;
-
-M: sequence hi-tag-test reverse ;
-
-[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
-
-[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
-
-[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
-
-TUPLE: shape ;
-
-TUPLE: abstract-rectangle < shape width height ;
-
-TUPLE: rectangle < abstract-rectangle ;
-
-C: <rectangle> rectangle
-
-TUPLE: parallelogram < abstract-rectangle skew ;
-
-C: <parallelogram> parallelogram
-
-TUPLE: circle < shape radius ;
-
-C: <circle> circle
-
-GENERIC: area ( shape -- n )
-
-M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
-
-M: circle area radius>> sq pi * ;
-
-[ 12 ] [ 4 3 <rectangle> area ] unit-test
-[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
-[ t ] [ 2 <circle> area 4 pi * = ] unit-test
-
-GENERIC: perimiter ( shape -- n )
-
-: rectangle-perimiter ( l w -- n ) + 2 * ;
-
-M: rectangle perimiter
- [ width>> ] [ height>> ] bi
- rectangle-perimiter ;
-
-: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
-
-M: parallelogram perimiter
- [ width>> ]
- [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
- rectangle-perimiter ;
-
-M: circle perimiter 2 * pi * ;
-
-[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
-[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
-
-GENERIC: big-mix-test ( obj -- obj' )
-
-M: object big-mix-test drop "object" ;
-
-M: tuple big-mix-test drop "tuple" ;
-
-M: integer big-mix-test drop "integer" ;
-
-M: float big-mix-test drop "float" ;
-
-M: complex big-mix-test drop "complex" ;
-
-M: string big-mix-test drop "string" ;
-
-M: array big-mix-test drop "array" ;
-
-M: sequence big-mix-test drop "sequence" ;
-
-M: rectangle big-mix-test drop "rectangle" ;
-
-M: parallelogram big-mix-test drop "parallelogram" ;
-
-M: circle big-mix-test drop "circle" ;
-
-[ "integer" ] [ 3 big-mix-test ] unit-test
-[ "float" ] [ 5.0 big-mix-test ] unit-test
-[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
-[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
-[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
-[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
-[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
-[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
-[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
-[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
-[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
-[ "string" ] [ "hello" big-mix-test ] unit-test
-[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
-[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
-[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
-[ "tuple" ] [ H{ } big-mix-test ] unit-test
-[ "object" ] [ \ + big-mix-test ] unit-test
-
-GENERIC: small-lo-tag ( obj -- obj )
-
-M: fixnum small-lo-tag drop "fixnum" ;
-
-M: string small-lo-tag drop "string" ;
-
-M: array small-lo-tag drop "array" ;
-
-M: double-array small-lo-tag drop "double-array" ;
-
-M: byte-array small-lo-tag drop "byte-array" ;
-
-[ "fixnum" ] [ 3 small-lo-tag ] unit-test
-
-[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
-
-! Testing next-method
-TUPLE: person ;
-
-TUPLE: intern < person ;
-
-TUPLE: employee < person ;
-
-TUPLE: tape-monkey < employee ;
-
-TUPLE: manager < employee ;
-
-TUPLE: junior-manager < manager ;
-
-TUPLE: middle-manager < manager ;
-
-TUPLE: senior-manager < manager ;
-
-TUPLE: executive < senior-manager ;
-
-TUPLE: ceo < executive ;
-
-GENERIC: salary ( person -- n )
-
-M: intern salary
- #! Intentional mistake.
- call-next-method ;
-
-M: employee salary drop 24000 ;
-
-M: manager salary call-next-method 12000 + ;
-
-M: middle-manager salary call-next-method 5000 + ;
-
-M: senior-manager salary call-next-method 15000 + ;
-
-M: executive salary call-next-method 2 * ;
-
-M: ceo salary
- #! Intentional error.
- drop 5 call-next-method 3 * ;
-
-[ salary ] must-infer
-
-[ 24000 ] [ employee boa salary ] unit-test
-
-[ 24000 ] [ tape-monkey boa salary ] unit-test
-
-[ 36000 ] [ junior-manager boa salary ] unit-test
-
-[ 41000 ] [ middle-manager boa salary ] unit-test
-
-[ 51000 ] [ senior-manager boa salary ] unit-test
-
-[ 102000 ] [ executive boa salary ] unit-test
-
-[ ceo boa salary ]
-[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
-
-[ intern boa salary ]
-[ no-next-method? ] must-fail-with
-
-! Weird shit
-TUPLE: a ;
-TUPLE: b ;
-TUPLE: c ;
-
-UNION: x a b ;
-UNION: y a c ;
-
-UNION: z x y ;
-
-GENERIC: funky* ( obj -- )
-
-M: z funky* "z" , drop ;
-
-M: x funky* "x" , call-next-method ;
-
-M: y funky* "y" , call-next-method ;
-
-M: a funky* "a" , call-next-method ;
-
-M: b funky* "b" , call-next-method ;
-
-M: c funky* "c" , call-next-method ;
-
-: funky ( obj -- seq ) [ funky* ] { } make ;
-
-[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
-
-[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
-
-[ t ] [
- T{ a } funky
- { { "a" "x" "z" } { "a" "y" "z" } } member?
-] unit-test
-
-! Hooks
-SYMBOL: my-var
-HOOK: my-hook my-var ( -- x )
-
-M: integer my-hook "an integer" ;
-M: string my-hook "a string" ;
-
-[ "an integer" ] [ 3 my-var set my-hook ] unit-test
-[ "a string" ] [ my-hook my-var set my-hook ] unit-test
-[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-
-HOOK: my-tuple-hook my-var ( -- x )
-
-M: sequence my-tuple-hook my-hook ;
-
-TUPLE: m-t-h-a ;
-
-M: m-t-h-a my-tuple-hook "foo" ;
-
-TUPLE: m-t-h-b < m-t-h-a ;
-
-M: m-t-h-b my-tuple-hook "bar" ;
-
-[ f ] [
- \ my-tuple-hook [ "engines" word-prop ] keep prefix
- [ 1quotation infer ] map all-equal?
-] unit-test
-
-HOOK: call-next-hooker my-var ( -- x )
-
-M: sequence call-next-hooker "sequence" ;
-
-M: array call-next-hooker call-next-method "array " prepend ;
-
-M: vector call-next-hooker call-next-method "vector " prepend ;
-
-M: growable call-next-hooker call-next-method "growable " prepend ;
-
-[ "vector growable sequence" ] [
- V{ } my-var [ call-next-hooker ] with-variable
-] unit-test
-
-[ t ] [
- { } \ nth effective-method nip \ sequence \ nth method eq?
-] unit-test
-
-[ t ] [
- \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
-] unit-test
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel kernel.private slots.private math
-namespaces make sequences vectors words quotations definitions
-hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private generic.standard.engines
-generic.standard.engines.tag generic.standard.engines.predicate
-generic.standard.engines.tuple accessors ;
+USING: accessors definitions generic generic.single kernel
+namespaces words math combinators sequences ;
IN: generic.standard
-GENERIC: dispatch# ( word -- n )
-
-M: generic dispatch#
- "combination" word-prop dispatch# ;
-
-GENERIC: method-declaration ( class generic -- quot )
-
-M: generic method-declaration
- "combination" word-prop method-declaration ;
-
-M: quotation engine>quot
- assumed get generic get method-declaration prepend ;
-
-ERROR: no-method object generic ;
-
-: error-method ( word -- quot )
- [ picker ] dip [ no-method ] curry append ;
-
-: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-dispatch-engine> ] unless*
- [ methods>> set-at ] keep
- ] change-at ;
-
-: flatten-method ( class method assoc -- )
- [ [ flatten-class keys ] keep ] 2dip [
- [ spin ] dip push-method
- ] 3curry each ;
-
-: flatten-methods ( assoc -- assoc' )
- H{ } clone [
- [
- flatten-method
- ] curry assoc-each
- ] keep ;
-
-: <big-dispatch-engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- convert-hi-tag-methods
- <lo-tag-dispatch-engine> ;
-
-: mangle-method ( method -- quot )
- 1quotation generic get extra-values \ drop <repetition>
- prepend [ ] like ;
-
-: find-default ( methods -- quot )
- #! Side-effects methods.
- [ object bootstrap-word ] dip delete-at* [
- drop generic get "default-method" word-prop mangle-method
- ] unless ;
-
-: <standard-engine> ( word -- engine )
- object bootstrap-word assumed set {
- [ generic set ]
- [ "engines" word-prop forget-all ]
- [ V{ } clone "engines" set-word-prop ]
- [
- "methods" word-prop
- [ mangle-method ] assoc-map
- [ find-default default set ]
- [ <big-dispatch-engine> ]
- bi
- ]
- } cleave ;
-
-: single-combination ( word -- quot )
- [ <standard-engine> engine>quot ] with-scope ;
-
-ERROR: inconsistent-next-method class generic ;
-
-: single-next-method-quot ( class generic -- quot/f )
- 2dup next-method dup [
- [
- pick "predicate" word-prop %
- 1quotation ,
- [ inconsistent-next-method ] 2curry ,
- \ if ,
- ] [ ] make
- ] [ 3drop f ] if ;
-
-: single-effective-method ( obj word -- method )
- [ [ order [ instance? ] with find-last nip ] keep method ]
- [ "default-method" word-prop ]
- bi or ;
-
-TUPLE: standard-combination # ;
+TUPLE: standard-combination < single-combination # ;
C: <standard-combination> standard-combination
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
- "combination" word-prop #>> zero? ;
+ "combination" word-prop #>> 0 = ;
CONSTANT: simple-combination T{ standard-combination f 0 }
: define-simple-generic ( word effect -- )
[ simple-combination ] dip define-generic ;
-: with-standard ( combination quot -- quot' )
- [ #>> (dispatch#) ] dip with-variable ; inline
-
-M: standard-generic extra-values drop 0 ;
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- (picker) [ dip swap ] curry ]
+ } case ;
-M: standard-combination make-default-method
- [ error-method ] with-standard ;
-
-M: standard-combination perform-combination
- [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+M: standard-combination picker
+ combination get #>> (picker) ;
M: standard-combination dispatch# #>> ;
-M: standard-combination method-declaration
- dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
-
-M: standard-combination next-method-quot*
- [
- single-next-method-quot
- dup [ picker prepend ] when
- ] with-standard ;
-
M: standard-generic effective-method
- [ dispatch# (picker) call ] keep single-effective-method ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-PREDICATE: hook-generic < generic
- "combination" word-prop hook-combination? ;
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- [ hook-combination ] dip with-variable
- ] with-variable ; inline
-
-: prepend-hook-var ( quot -- quot' )
- hook-combination get var>> [ get ] curry prepend ;
-
-M: hook-combination dispatch# drop 0 ;
-
-M: hook-combination method-declaration 2drop [ ] ;
-
-M: hook-generic extra-values drop 1 ;
-
-M: hook-generic effective-method
- [ "combination" word-prop var>> get ] keep
- single-effective-method ;
-
-M: hook-combination make-default-method
- [ error-method prepend-hook-var ] with-hook ;
-
-M: hook-combination perform-combination
- [ drop ] [
- [ single-combination prepend-hook-var ] with-hook
- ] 2bi define ;
-
-M: hook-combination next-method-quot*
- [
- single-next-method-quot
- dup [ prepend-hook-var ] when
- ] with-hook ;
-
-M: simple-generic definer drop \ GENERIC: f ;
+ [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
+ (effective-method) ;
M: standard-generic definer drop \ GENERIC# f ;
-M: hook-generic definer drop \ HOOK: f ;
+M: simple-generic definer drop \ GENERIC: f ;
+++ /dev/null
-Standard method combination used for most generic words
{ $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" }
} ;
+HELP: execute
+{ $values { "word" word } }
+{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." }
+{ $examples
+ { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
+} ;
+
+{ execute POSTPONE: execute( } related-words
+
+HELP: (execute)
+{ $values { "word" word } }
+{ $description "Executes a word without checking if it is a word first." }
+{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is unsafe. Calling with a parameter that is not a word will crash Factor. Use " { $link execute } " instead." } ;
+
HELP: call
{ $values { "callable" callable } }
{ $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." }
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes
math.order kernel.private ;
SYMBOL: type-numbers
-: tag-number ( class -- n )
- tag-numbers get at [ object tag-number ] unless* ;
-
: type-number ( class -- n )
type-numbers get at ;
+: tag-number ( class -- n )
+ type-number dup num-tags get >= [ drop object tag-number ] when ;
+
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
USING: arrays help.markup help.syntax math
sequences.private vectors strings kernel math.order layouts
-quotations generic.standard ;
+quotations generic.single ;
IN: sequences
HELP: sequence
{ $subsection produce }
{ $subsection produce-as }
"Filtering:"
-{ $subsection push-if }
{ $subsection filter }
+{ $subsection partition }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection any? }
{ $subsection all? }
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard classes.tuple generic.math
-generic.standard arrays io.pathnames vocabs.loader io sequences
-assocs words.symbol words.alias words.constant combinators ;
+generic.standard generic.single arrays io.pathnames vocabs.loader io
+sequences assocs words.symbol words.alias words.constant combinators ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
hashtables kernel math namespaces parser lexer sequences strings
strings.parser sbufs vectors words words.symbol words.constant
words.alias quotations io assocs splitting classes.tuple
-generic.standard generic.math generic.parser classes
+generic.standard generic.hook generic.math generic.parser classes
io.pathnames vocabs vocabs.parser classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
USING: definitions help.markup help.syntax kernel parser
-kernel.private words.private vocabs classes quotations
+kernel.private vocabs classes quotations
strings effects compiler.units ;
IN: words
ABOUT: "words"
-HELP: execute ( word -- )
-{ $values { "word" word } }
-{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." }
-{ $examples
- { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
-} ;
-
-{ execute POSTPONE: execute( } related-words
-
HELP: deferred
{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ;
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions graphs assocs kernel
-kernel.private slots.private math namespaces sequences strings
-vectors sbufs quotations assocs hashtables sorting words.private
-vocabs math.order sets ;
+kernel.private kernel.private slots.private math namespaces sequences
+strings vectors sbufs quotations assocs hashtables sorting vocabs
+math.order sets ;
IN: words
: word ( -- word ) \ word get-global ;
: reset-generic ( word -- )
[ subwords forget-all ]
[ reset-word ]
- [ { "methods" "combination" "default-method" } reset-props ]
- tri ;
+ [
+ {
+ "methods"
+ "combination"
+ "default-method"
+ "engines"
+ "decision-tree"
+ } reset-props
+ ] tri ;
: gensym ( -- word )
"( gensym )" f <word> ;
case WORD_TYPE:
word = (F_WORD *)scan;
if(word->code)
- mark_code_block(word->code);
+ mark_code_block(word->code);
if(word->profiling)
mark_code_block(word->profiling);
break;
GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
GROWABLE_ARRAY_TRIM(stats);
+ GROWABLE_ARRAY_DONE(stats);
dpush(stats);
}
/* If this is defined, we GC every 100 allocations. This catches missing local roots */
#ifdef GC_DEBUG
-static int count;
+int gc_count;
#endif
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
+int count;
INLINE void *allot_object(CELL type, CELL a)
{
-
#ifdef GC_DEBUG
-
if(!gc_off)
{
- if(count++ % 1000 == 0)
+ if(gc_count++ % 1000 == 0)
gc();
}
type = untag_header(value);
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
- return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
+ return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE);
}
/* Push object at heap scan cursor and advance; pushes f when done */
gc_off = false;
GROWABLE_ARRAY_TRIM(words);
+ GROWABLE_ARRAY_DONE(words);
return words;
}
--- /dev/null
+#include "master.h"
+
+static CELL search_lookup_alist(CELL table, CELL class)
+{
+ F_ARRAY *pairs = untag_object(table);
+ F_FIXNUM index = array_capacity(pairs) - 1;
+ while(index >= 0)
+ {
+ F_ARRAY *pair = untag_object(array_nth(pairs,index));
+ if(array_nth(pair,0) == class)
+ return array_nth(pair,1);
+ else
+ index--;
+ }
+
+ return F;
+}
+
+static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode)
+{
+ F_ARRAY *buckets = untag_object(table);
+ CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
+ if(type_of(bucket) == WORD_TYPE || bucket == F)
+ return bucket;
+ else
+ return search_lookup_alist(bucket,class);
+}
+
+static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
+{
+ CELL *ptr = (CELL *)(layout + 1);
+ return ptr[echelon * 2];
+}
+
+static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
+{
+ CELL *ptr = (CELL *)(layout + 1);
+ return ptr[echelon * 2 + 1];
+}
+
+INLINE CELL method_cache_hashcode(F_TUPLE_LAYOUT *layout, F_ARRAY *array)
+{
+ CELL capacity = (array_capacity(array) >> 1) - 1;
+ return (((CELL)layout >> TAG_BITS) & capacity) << 1;
+}
+
+INLINE CELL lookup_tuple_method_fast(F_TUPLE_LAYOUT *layout, CELL method_cache)
+{
+ F_ARRAY *array = untag_object(method_cache);
+ CELL hashcode = method_cache_hashcode(layout,array);
+ if(array_nth(array,hashcode) == tag_object(layout))
+ return array_nth(array,hashcode + 1);
+ else
+ return F;
+}
+
+static CELL lookup_tuple_method_slow(F_TUPLE_LAYOUT *layout, CELL methods)
+{
+ F_ARRAY *echelons = untag_object(methods);
+
+ F_FIXNUM echelon = untag_fixnum_fast(layout->echelon);
+ F_FIXNUM max_echelon = array_capacity(echelons) - 1;
+ if(echelon > max_echelon) echelon = max_echelon;
+
+ while(echelon >= 0)
+ {
+ CELL echelon_methods = array_nth(echelons,echelon);
+
+ if(type_of(echelon_methods) == WORD_TYPE)
+ return echelon_methods;
+ else if(echelon_methods != F)
+ {
+ CELL class = nth_superclass(layout,echelon);
+ CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon));
+ CELL result = search_lookup_hash(echelon_methods,class,hashcode);
+ if(result != F)
+ return result;
+ }
+
+ echelon--;
+ }
+
+ critical_error("Cannot find tuple method",methods);
+ return F;
+}
+
+static void update_method_cache(F_TUPLE_LAYOUT *layout, CELL method_cache, CELL method)
+{
+ F_ARRAY *array = untag_object(method_cache);
+ CELL hashcode = method_cache_hashcode(layout,array);
+ set_array_nth(array,hashcode,tag_object(layout));
+ set_array_nth(array,hashcode + 1,method);
+}
+
+static CELL lookup_tuple_method(CELL object, CELL methods, CELL method_cache)
+{
+ F_TUPLE *tuple = untag_object(object);
+ F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
+
+ CELL method = lookup_tuple_method_fast(layout,method_cache);
+ if(method == F)
+ {
+ local_cache_misses++;
+ method = lookup_tuple_method_slow(layout,methods);
+ update_method_cache(layout,method_cache,method);
+ }
+
+ return method;
+}
+
+static CELL lookup_hi_tag_method(CELL object, CELL methods)
+{
+ F_ARRAY *hi_tag_methods = untag_object(methods);
+ CELL hi_tag = object_type(object);
+ return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE);
+}
+
+static CELL lookup_method(CELL object, CELL methods, CELL method_cache)
+{
+ F_ARRAY *tag_methods = untag_object(methods);
+ CELL tag = TAG(object);
+ CELL element = array_nth(tag_methods,tag);
+
+ if(type_of(element) == WORD_TYPE)
+ return element;
+ else
+ {
+ switch(tag)
+ {
+ case TUPLE_TYPE:
+ return lookup_tuple_method(object,element,method_cache);
+ case OBJECT_TYPE:
+ return lookup_hi_tag_method(object,element);
+ default:
+ critical_error("Bad methods array",methods);
+ return F;
+ }
+ }
+}
+
+void primitive_lookup_method(void)
+{
+ CELL method_cache = get(ds);
+ CELL methods = get(ds - CELLS);
+ CELL object = get(ds - CELLS * 2);
+ ds -= CELLS * 2;
+ drepl(lookup_method(object,methods,method_cache));
+}
--- /dev/null
+u64 local_cache_misses;
+
+void primitive_lookup_method(void);
#define F_TYPE 7
#define F F_TYPE
-#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
+#define HEADER_TYPE 8 /* anything less than this is a tag */
#define GC_COLLECTED 5 /* See gc.c */
DEFPUSHPOP(gc_local_,gc_locals)
-#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
+#define REGISTER_ROOT(obj) gc_local_push((CELL)&(obj))
#define UNREGISTER_ROOT(obj) \
{ \
- if(gc_local_pop() != (CELL)&obj) \
+ if(gc_local_pop() != (CELL)&(obj)) \
critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
}
#include "callstack.h"
#include "alien.h"
#include "quotations.h"
+#include "dispatch.h"
#include "factor.h"
#include "utilities.h"
primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
- primitive_check_datastack
+ primitive_check_datastack,
+ primitive_lookup_method
};
&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
}
-F_ARRAY *code_to_emit(CELL code)
-{
- return untag_object(array_nth(untag_object(code),0));
-}
-
-F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
-{
- F_ARRAY *quadruple = untag_object(code);
- CELL rel_class = array_nth(quadruple,1);
- CELL rel_type = array_nth(quadruple,2);
- CELL offset = array_nth(quadruple,3);
-
- if(rel_class == F)
- {
- *rel_p = false;
- return 0;
- }
- else
- {
- *rel_p = true;
- return (to_fixnum(rel_type) << 28)
- | (to_fixnum(rel_class) << 24)
- | ((code_length + to_fixnum(offset)) * code_format);
- }
-}
-
-#define EMIT(name) { \
- bool rel_p; \
- F_REL rel = rel_to_emit(name,code_format,code_count,&rel_p); \
- if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
- GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
- }
-
bool jit_stack_frame_p(F_ARRAY *array)
{
F_FIXNUM length = array_capacity(array);
quot->compiledp = T;
}
+F_ARRAY *code_to_emit(CELL template)
+{
+ return untag_object(array_nth(untag_object(template),0));
+}
+
+F_REL rel_to_emit(CELL template, CELL code_format, CELL code_length, bool *rel_p)
+{
+ F_ARRAY *quadruple = untag_object(template);
+ CELL rel_class = array_nth(quadruple,1);
+ CELL rel_type = array_nth(quadruple,2);
+ CELL offset = array_nth(quadruple,3);
+
+ if(rel_class == F)
+ {
+ *rel_p = false;
+ return 0;
+ }
+ else
+ {
+ *rel_p = true;
+ return (to_fixnum(rel_type) << 28)
+ | (to_fixnum(rel_class) << 24)
+ | ((code_length + to_fixnum(offset)) * code_format);
+ }
+}
+
+static void jit_emit(CELL template, CELL code_format,
+ F_GROWABLE_ARRAY *code, F_GROWABLE_BYTE_ARRAY *relocation)
+{
+ REGISTER_ROOT(template);
+ bool rel_p;
+ F_REL rel = rel_to_emit(template,code_format,code->count,&rel_p);
+ if(rel_p) growable_byte_array_append(relocation,&rel,sizeof(F_REL));
+ growable_array_append(code,code_to_emit(template));
+ UNREGISTER_ROOT(template);
+}
+
+#define EMIT(template) { jit_emit(template,code_format,&code_g,&relocation_g); }
+
+#define EMIT_LITERAL GROWABLE_ARRAY_ADD(literals,obj);
+
+#define EMIT_TAIL_CALL(template) { \
+ if(stack_frame) EMIT(userenv[JIT_EPILOG]); \
+ tail_call = true; \
+ EMIT(template); \
+ }
+
/* Might GC */
void jit_compile(CELL quot, bool relocate)
{
CELL code_format = compiled_code_format();
- REGISTER_ROOT(quot);
-
CELL array = untag_quotation(quot)->array;
+
+ REGISTER_ROOT(quot);
REGISTER_ROOT(array);
GROWABLE_ARRAY(code);
- REGISTER_ROOT(code);
-
GROWABLE_BYTE_ARRAY(relocation);
- REGISTER_ROOT(relocation);
-
GROWABLE_ARRAY(literals);
- REGISTER_ROOT(literals);
if(stack_traces_p())
GROWABLE_ARRAY_ADD(literals,quot);
bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame)
- EMIT(userenv[JIT_PROLOG]);
+ EMIT(userenv[JIT_PROLOG])
CELL i;
CELL length = array_capacity(untag_object(array));
/* Intrinsics */
if(word->subprimitive != F)
{
+ REGISTER_UNTAGGED(word);
if(array_nth(untag_object(word->subprimitive),1) != F)
- {
GROWABLE_ARRAY_ADD(literals,T);
- }
+ UNREGISTER_UNTAGGED(word);
- EMIT(word->subprimitive);
+ EMIT(word->subprimitive)
+ }
+ else if(obj == userenv[JIT_EXECUTE_WORD])
+ {
+ if(i == length - 1)
+ EMIT_TAIL_CALL(userenv[JIT_EXECUTE_JUMP])
+ else
+ EMIT(userenv[JIT_EXECUTE_CALL])
}
else
{
- GROWABLE_ARRAY_ADD(literals,obj);
+ EMIT_LITERAL
if(i == length - 1)
- {
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- EMIT(userenv[JIT_WORD_JUMP]);
-
- tail_call = true;
- }
+ EMIT_TAIL_CALL(userenv[JIT_WORD_JUMP])
else
- EMIT(userenv[JIT_WORD_CALL]);
+ EMIT(userenv[JIT_WORD_CALL])
}
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,wrapper->object);
- EMIT(userenv[JIT_PUSH_IMMEDIATE]);
+ EMIT(userenv[JIT_PUSH_IMMEDIATE])
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
- EMIT(userenv[JIT_SAVE_STACK]);
- GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[JIT_PRIMITIVE]);
+ EMIT(userenv[JIT_SAVE_STACK])
+ EMIT_LITERAL
+ EMIT(userenv[JIT_PRIMITIVE])
i++;
if(jit_fast_if_p(untag_object(array),i))
{
if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
+ EMIT(userenv[JIT_EPILOG])
+
+ tail_call = true;
jit_compile(array_nth(untag_object(array),i),relocate);
jit_compile(array_nth(untag_object(array),i + 1),relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_IF_1]);
+ EMIT(userenv[JIT_IF_1])
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
- EMIT(userenv[JIT_IF_2]);
+ EMIT(userenv[JIT_IF_2])
i += 2;
- tail_call = true;
break;
}
else if(jit_fast_dip_p(untag_object(array),i))
{
jit_compile(obj,relocate);
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DIP]);
+ EMIT_LITERAL
+ EMIT(userenv[JIT_DIP])
i++;
break;
{
jit_compile(obj,relocate);
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_2DIP]);
+ EMIT_LITERAL
+ EMIT(userenv[JIT_2DIP])
i++;
break;
{
jit_compile(obj,relocate);
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_3DIP]);
+ EMIT_LITERAL
+ EMIT(userenv[JIT_3DIP])
i++;
break;
case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i))
{
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DISPATCH]);
+ EMIT_LITERAL
+ EMIT_TAIL_CALL(userenv[JIT_DISPATCH])
i++;
-
- tail_call = true;
break;
}
else if(jit_ignore_declare_p(untag_object(array),i))
break;
}
default:
- GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[JIT_PUSH_IMMEDIATE]);
+ EMIT_LITERAL
+ EMIT(userenv[JIT_PUSH_IMMEDIATE])
break;
}
}
if(!tail_call)
{
if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
+ EMIT(userenv[JIT_EPILOG])
- EMIT(userenv[JIT_RETURN]);
+ EMIT(userenv[JIT_RETURN])
}
- GROWABLE_ARRAY_TRIM(code);
GROWABLE_ARRAY_TRIM(literals);
GROWABLE_BYTE_ARRAY_TRIM(relocation);
+ GROWABLE_ARRAY_TRIM(code);
F_CODE_BLOCK *compiled = add_code_block(
QUOTATION_TYPE,
if(relocate)
relocate_code_block(compiled);
- UNREGISTER_ROOT(literals);
- UNREGISTER_ROOT(relocation);
- UNREGISTER_ROOT(code);
+ GROWABLE_ARRAY_DONE(literals);
+ GROWABLE_BYTE_ARRAY_DONE(relocation);
+ GROWABLE_ARRAY_DONE(code);
+
UNREGISTER_ROOT(array);
UNREGISTER_ROOT(quot);
}
offset -= size; \
}
+#define COUNT_TAIL_CALL(name,scan) { \
+ if(stack_frame) COUNT(userenv[JIT_EPILOG],scan) \
+ tail_call = true; \
+ COUNT(name,scan); \
+ }
+
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
{
CELL code_format = compiled_code_format();
word = untag_object(obj);
if(word->subprimitive != F)
COUNT(word->subprimitive,i)
- else if(i == length - 1)
+ else if(obj == userenv[JIT_EXECUTE_WORD])
{
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i);
-
- COUNT(userenv[JIT_WORD_JUMP],i)
-
- tail_call = true;
+ if(i == length - 1)
+ COUNT_TAIL_CALL(userenv[JIT_EXECUTE_JUMP],i)
+ else
+ COUNT(userenv[JIT_EXECUTE_CALL],i)
}
+ else if(i == length - 1)
+ COUNT_TAIL_CALL(userenv[JIT_WORD_JUMP],i)
else
COUNT(userenv[JIT_WORD_CALL],i)
break;
{
if(stack_frame)
COUNT(userenv[JIT_EPILOG],i)
+ tail_call = true;
COUNT(userenv[JIT_IF_1],i)
COUNT(userenv[JIT_IF_2],i)
i += 2;
- tail_call = true;
break;
}
else if(jit_fast_dip_p(untag_object(array),i))
case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i))
{
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i)
-
i++;
-
- COUNT(userenv[JIT_DISPATCH],i)
-
- tail_call = true;
+ COUNT_TAIL_CALL(userenv[JIT_DISPATCH],i)
break;
}
if(jit_ignore_declare_p(untag_object(array),i))
{
if(offset == 0) return i;
-
i++;
-
break;
}
default:
JIT_2DIP,
JIT_3DIP_WORD,
JIT_3DIP,
+ JIT_EXECUTE_WORD,
+ JIT_EXECUTE_JUMP,
+ JIT_EXECUTE_CALL,
STACK_TRACES_ENV = 59,
dpush(tag_object(reallot_array(array,capacity)));
}
-F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
+void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt)
{
+ F_ARRAY *underlying = untag_object(array->array);
REGISTER_ROOT(elt);
- if(*result_count == array_capacity(result))
+ if(array->count == array_capacity(underlying))
{
- result = reallot_array(result,*result_count * 2);
+ underlying = reallot_array(underlying,array->count * 2);
+ array->array = tag_object(underlying);
}
UNREGISTER_ROOT(elt);
- set_array_nth(result,*result_count,elt);
- (*result_count)++;
-
- return result;
+ set_array_nth(underlying,array->count++,elt);
}
-F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts)
{
REGISTER_UNTAGGED(elts);
+ F_ARRAY *underlying = untag_object(array->array);
+
CELL elts_size = array_capacity(elts);
- CELL new_size = *result_count + elts_size;
+ CELL new_size = array->count + elts_size;
- if(new_size >= array_capacity(result))
- result = reallot_array(result,new_size * 2);
+ if(new_size >= array_capacity(underlying))
+ {
+ underlying = reallot_array(underlying,new_size * 2);
+ array->array = tag_object(underlying);
+ }
UNREGISTER_UNTAGGED(elts);
- write_barrier((CELL)result);
+ write_barrier((CELL)array->array);
- memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
+ memcpy((void *)AREF(underlying,array->count),
+ (void *)AREF(elts,0),
+ elts_size * CELLS);
- *result_count += elts_size;
-
- return result;
+ array->count += elts_size;
}
/* Byte arrays */
dpush(tag_object(reallot_byte_array(array,capacity)));
}
-F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
+void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len)
{
- CELL new_size = *result_count + len;
-
- if(new_size >= byte_array_capacity(result))
- result = reallot_byte_array(result,new_size * 2);
+ CELL new_size = array->count + len;
+ F_BYTE_ARRAY *underlying = untag_object(array->array);
- memcpy((void *)BREF(result,*result_count),elts,len);
+ if(new_size >= byte_array_capacity(underlying))
+ {
+ underlying = reallot_byte_array(underlying,new_size * 2);
+ array->array = tag_object(underlying);
+ }
- *result_count = new_size;
+ memcpy((void *)BREF(underlying,array->count),elts,len);
- return result;
+ array->count += len;
}
/* Tuples */
return RETAG(tuple,TUPLE_TYPE);
}
-INLINE F_TUPLE *untag_tuple(CELL object)
-{
- type_check(TUPLE_TYPE,object);
- return untag_object(object);
-}
-
INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
{
CELL size = untag_fixnum_fast(layout->size);
void primitive_wrapper(void);
/* Macros to simulate a vector in C */
-#define GROWABLE_ARRAY(result) \
- CELL result##_count = 0; \
- CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
+typedef struct {
+ CELL count;
+ CELL array;
+} F_GROWABLE_ARRAY;
+
+INLINE F_GROWABLE_ARRAY make_growable_array(void)
+{
+ F_GROWABLE_ARRAY result;
+ result.count = 0;
+ result.array = tag_object(allot_array(ARRAY_TYPE,10000,F));
+ return result;
+}
+
+#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \
+ REGISTER_ROOT(result##_g.array)
-F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
+void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt);
#define GROWABLE_ARRAY_ADD(result,elt) \
- result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
+ growable_array_add(&result##_g,elt)
-F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
+void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts);
#define GROWABLE_ARRAY_APPEND(result,elts) \
- result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
+ growable_array_append(&result##_g,elts)
+
+INLINE CELL growable_array_trim(F_GROWABLE_ARRAY *array)
+{
+ return tag_object(reallot_array(untag_object(array->array),array->count));
+}
-#define GROWABLE_ARRAY_TRIM(result) \
- result = tag_object(reallot_array(untag_object(result),result##_count))
+#define GROWABLE_ARRAY_TRIM(result) CELL result = growable_array_trim(&result##_g)
+
+#define GROWABLE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array)
/* Macros to simulate a byte vector in C */
+typedef struct {
+ CELL count;
+ CELL array;
+} F_GROWABLE_BYTE_ARRAY;
+
+INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void)
+{
+ F_GROWABLE_BYTE_ARRAY result;
+ result.count = 0;
+ result.array = tag_object(allot_byte_array(10000));
+ return result;
+}
+
#define GROWABLE_BYTE_ARRAY(result) \
- CELL result##_count = 0; \
- CELL result = tag_object(allot_byte_array(100))
+ F_GROWABLE_BYTE_ARRAY result##_g = make_growable_byte_array(); \
+ REGISTER_ROOT(result##_g.array)
-F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
+void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len);
#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
- result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
+ growable_byte_array_append(&result##_g,elts,len)
+
+INLINE CELL growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
+{
+ return tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
+}
+
+#define GROWABLE_BYTE_ARRAY_TRIM(result) CELL result = growable_byte_array_trim(&result##_g)
-#define GROWABLE_BYTE_ARRAY_TRIM(result) \
- result = tag_object(reallot_byte_array(untag_object(result),result##_count))
+#define GROWABLE_BYTE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array);
projects / factor.git / commitdiff