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

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2008-11-06 22:36:05 -08:00
parent 140835ec3f 070432d140
commit 2957d1cd01
259 changed files with 1947 additions and 979 deletions
basis
alien/strings
bootstrap
compiler
concurrency
cpu
help/handbook
hints
io
buffers
encodings/ascii
ports
streams/memory
locals
math/intervals
mirrors
prettyprint/backend
random
regexp
stack-checker/known-words
tools/deploy
ui/tools/deploy
Show More

6
basis/alien/strings/strings-tests.factor
View File

@ -1,6 +1,6 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien ;
io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]
@ -28,3 +28,7 @@ unit-test
] unit-test
[ f ] [ f utf8 alien>string ] unit-test
[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test

10
basis/bootstrap/compiler/compiler.factor
View File

@ -89,14 +89,24 @@ nl
. malloc calloc free memcpy
} compile-uncompiled
"." write flush
{ build-tree } compile-uncompiled
"." write flush
{ optimize-tree } compile-uncompiled
"." write flush
{ optimize-cfg } compile-uncompiled
"." write flush
{ (compile) } compile-uncompiled
"." write flush
vocabs [ words compile-uncompiled "." write flush ] each
" done" print flush

36
basis/bootstrap/image/image.factor
View File

@ -368,31 +368,35 @@ M: byte-array '
M: tuple ' emit-tuple ;
M: tuple-layout '
[
[
{
[ hashcode>> , ]
[ class>> , ]
[ size>> , ]
[ superclasses>> , ]
[ echelon>> , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache-object ;
M: tombstone '
state>> "((tombstone))" "((empty))" ?
"hashtables.private" lookup def>> first
[ emit-tuple ] cache-object ;
! Arrays
M: array '
: emit-array ( array -- offset )
[ ' ] map array type-number object tag-number
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
M: array ' emit-array ;
! This is a hack. We need to detect arrays which are tuple
! layout arrays so that they can be internalized, but making
! them a built-in type is not worth it.
PREDICATE: tuple-layout-array < array
dup length 5 >= [
[ first tuple-class? ]
[ second fixnum? ]
[ third fixnum? ]
tri and and
] [ drop f ] if ;
M: tuple-layout-array '
[
[ dup integer? [ <fake-bignum> ] when ] map
emit-array
] cache-object ;
! Quotations
M: quotation '

16
basis/bootstrap/random/random.factor
View File

@ -1,16 +0,0 @@
USING: vocabs.loader sequences system
random random.mersenne-twister combinators init
namespaces random ;
IN: bootstrap.random
"random.mersenne-twister" require
{
{ [ os windows? ] [ "random.windows" require ] }
{ [ os unix? ] [ "random.unix" require ] }
} cond
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
] "bootstrap.random" add-init-hook

2
basis/bootstrap/stage2.factor
View File

@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
default-image-name "output-image" set-global
"math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line

64
basis/compiler/cfg/builder/builder.factor
View File

@ -125,23 +125,61 @@ M: #recursive emit-node
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
first dup #push? [ literal>> t ] [ drop f f ] if
] [ drop f f ] if ;
: trivial-if? ( #if -- ? )
children>> first2
[ trivial-branch? [ t eq? ] when ]
[ trivial-branch? [ f eq? ] when ] bi*
and ;
: emit-trivial-if ( -- )
ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
: trivial-not-if? ( #if -- ? )
children>> first2
[ trivial-branch? [ f eq? ] when ]
[ trivial-branch? [ t eq? ] when ] bi*
and ;
: emit-trivial-not-if ( -- )
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
M: #if emit-node
ds-pop ##branch-t emit-if iterate-next ;
{
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
} cond iterate-next ;
! #dispatch
: trivial-dispatch-branch? ( nodes -- ? )
dup length 1 = [
first dup #call? [
word>> "intrinsic" word-prop not
] [ drop f ] if
] [ drop f ] if ;
: dispatch-branch ( nodes word -- label )
gensym [
[
V{ } clone node-stack set
##prologue
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep ;
over trivial-dispatch-branch? [
drop first word>>
] [
gensym [
[
V{ } clone node-stack set
##prologue
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep
] if ;
: dispatch-branches ( node -- )
children>> [

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -14,6 +14,7 @@ M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
@ -24,6 +25,7 @@ M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;

1
basis/compiler/cfg/hats/hats.factor
View File

@ -22,6 +22,7 @@ IN: compiler.cfg.hats
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline

3
basis/compiler/cfg/instructions/instructions.factor
View File

@ -71,6 +71,9 @@ INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
! String element access
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
! Integer arithmetic
INSN: ##add < ##commutative ;
INSN: ##add-imm < ##commutative-imm ;

2
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien
: prepare-alien-accessor ( infos -- offset-vreg )
<reversed> [ second class>> ] [ first ] bi
dup value-info-small-tagged? [
dup value-info-small-fixnum? [
literal>> (prepare-alien-accessor-imm)
] [ drop (prepare-alien-accessor) ] if ;

6
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -16,14 +16,14 @@ IN: compiler.cfg.intrinsics.allot
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )
[ size>> ds-load ] [ ^^load-literal ] bi prefix ;
[ second ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- )
dup node-input-infos peek literal>>
dup tuple-layout? [
dup array? [
nip
ds-drop
[ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
[ tuple-slot-regs ] [ second ^^allot-tuple ] bi
[ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ;

9
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
[ ds-pop ]
[ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
[ ]
tri*
call ; inline
: (emit-fixnum-op) ( insn -- dst )
@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum
] ; inline
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-tagged? [
dup node-input-infos dup second value-info-small-fixnum? [
nip
[ ds-drop ds-pop ] dip
second literal>> dup sgn {
@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum*fast ( node -- )
node-input-infos
dup second value-info-small-tagged?
dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
ds-push ;

3
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -14,6 +14,7 @@ QUALIFIED: arrays
QUALIFIED: byte-arrays
QUALIFIED: kernel.private
QUALIFIED: slots.private
QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: alien.accessors
@ -38,6 +39,7 @@ IN: compiler.cfg.intrinsics
kernel:eq?
slots.private:slot
slots.private:set-slot
strings.private:string-nth
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
@ -114,6 +116,7 @@ IN: compiler.cfg.intrinsics
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }

7
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots
dup node-input-infos
dup first value-tag [
nip
dup second value-info-small-tagged?
dup second value-info-small-fixnum?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
@ -46,8 +46,11 @@ IN: compiler.cfg.intrinsics.slots
dup second value-tag [
nip
[
dup third value-info-small-tagged?
dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
[ drop ] [ i i ##write-barrier ] if
] [ drop emit-primitive ] if ;
: emit-string-nth ( -- )
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;

18
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make cpu.architecture compiler.cfg.instructions
compiler.cfg.registers ;
combinators make classes words cpu.architecture
compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.stack-frame
SYMBOL: frame-required?
@ -24,16 +24,16 @@ M: ##stack-frame compute-stack-frame*
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: _gc compute-stack-frame*
drop frame-required? on ;
M: _spill compute-stack-frame*
drop frame-required? on ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame* drop ;
M: insn compute-stack-frame*
class frame-required? word-prop [
frame-required? on
] when ;
\ _gc t frame-required? set-word-prop
\ _spill t frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off

16
basis/compiler/cfg/utilities/utilities.factor
View File

@ -1,12 +1,24 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math layouts make sequences
USING: accessors kernel math layouts make sequences combinators
cpu.architecture namespaces compiler.cfg
compiler.cfg.instructions ;
IN: compiler.cfg.utilities
: value-info-small-fixnum? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
[ drop f ]
} cond ;
: value-info-small-tagged? ( value-info -- ? )
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
dup literal?>> [
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond
] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;

4
basis/compiler/cfg/value-numbering/propagate/propagate.factor
View File

@ -36,6 +36,10 @@ M: ##set-slot propagate
[ resolve ] change-obj
[ resolve ] change-slot ;
M: ##string-nth propagate
[ resolve ] change-obj
[ resolve ] change-index ;
M: ##set-slot-imm propagate
call-next-method
[ resolve ] change-obj ;

70
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -42,25 +42,75 @@ M: ##mul-imm rewrite
: tag-fixnum-expr? ( expr -- ? )
dup op>> \ ##shl-imm eq?
[ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ;
[ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
dup ##compare-imm-branch? [
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
bi and
] [ drop f ] if ; inline
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
bi and ; inline
: rewrite-tagged-comparison ( insn -- insn' )
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
[ src2>> tag-bits get neg shift ]
[ cc>> ]
tri
f \ ##compare-imm-branch boa ;
tri ; inline
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
dup ##compare-imm-branch? [
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
] when ;
: flip-comparison? ( insn -- ? )
dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
: flip-comparison ( insn -- insn' )
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
cc= f \ ##compare-imm boa ;
M: ##compare rewrite
dup flip-comparison? [
flip-comparison
dup number-values
rewrite
] when ;
: rewrite-redundant-comparison? ( insn -- ? )
[ src1>> vreg>expr compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
tri and and ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
M: ##compare-imm rewrite
dup rewrite-redundant-comparison? [
rewrite-redundant-comparison
dup number-values rewrite
] when
dup ##compare-imm? [
dup rewrite-tagged-comparison? [
rewrite-tagged-comparison
dup number-values rewrite
] when
] when ;
M: insn rewrite ;

76
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -1,6 +1,6 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel ;
compiler.cfg.registers cpu.architecture tools.test kernel math ;
[
{
T{ ##peek f V int-regs 45 D 1 }
@ -66,3 +66,77 @@ compiler.cfg.registers cpu.architecture tools.test kernel ;
T{ ##replace f V int-regs 3 D 0 }
} value-numbering
] unit-test
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 4 D 0 }
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
] unit-test
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 6 D 0 }
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
] unit-test
[
{
T{ ##peek f V int-regs 8 D 0 }
T{ ##peek f V int-regs 9 D -1 }
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
T{ ##replace f V int-regs 14 D 0 }
}
] [
{
T{ ##peek f V int-regs 8 D 0 }
T{ ##peek f V int-regs 9 D -1 }
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering
] unit-test
[
{
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
}
] [
{
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
} value-numbering
] unit-test

8
basis/compiler/codegen/codegen.factor
View File

@ -123,6 +123,14 @@ M: ##set-slot generate-insn
M: ##set-slot-imm generate-insn
>set-slot< %set-slot-imm ;
M: ##string-nth generate-insn
{
[ dst>> register ]
[ obj>> register ]
[ index>> register ]
[ temp>> register ]
} cleave %string-nth ;
: dst/src ( insn -- dst src )
[ dst>> register ] [ src>> register ] bi ; inline

71
basis/compiler/constants/constants.factor
View File

@ -1,49 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system ;
USING: math kernel layouts system strings ;
IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
: card-bits 8 ; inline
: deck-bits 18 ; inline
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ;
: float-offset ( -- n ) 8 float tag-number - ;
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
: header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute-cell 0 ; inline
: rc-absolute 1 ; inline
: rc-relative 2 ; inline
: rc-absolute-ppc-2/2 3 ; inline
: rc-relative-ppc-2 4 ; inline
: rc-relative-ppc-3 5 ; inline
: rc-relative-arm-3 6 ; inline
: rc-indirect-arm 7 ; inline
: rc-indirect-arm-pc 8 ; inline
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

32
basis/compiler/tests/intrinsics.factor
View File

@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ;
namespaces libc sequences.private io.encodings.ascii
classes ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
@ -27,6 +28,9 @@ IN: compiler.tests
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
[ { f f } ] [ 2 f <array> ] unit-test
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
@ -37,13 +41,19 @@ IN: compiler.tests
! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
!
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@ -158,6 +168,10 @@ IN: compiler.tests
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
@ -263,6 +277,8 @@ cell 8 = [
: compiled-fixnum>bignum fixnum>bignum ;
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
[ ] [
10000 [
32 random-bits >fixnum

20
basis/compiler/tests/redefine12.factor Normal file
View File

@ -0,0 +1,20 @@
USING: kernel tools.test eval ;
IN: compiler.tests.redefine12
! A regression that came about when fixing the
! 'no method on classes-intersect?' bug
GENERIC: g ( a -- b )
M: object g drop t ;
: h ( a -- b ) dup [ g ] when ;
[ f ] [ f h ] unit-test
[ t ] [ "hi" h ] unit-test
TUPLE: jeah ;
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
[ f ] [ T{ jeah } h ] unit-test

343
basis/compiler/tests/spilling.factor Normal file
View File

@ -0,0 +1,343 @@
USING: math.private kernel combinators accessors arrays
generalizations float-arrays tools.test ;
IN: compiler.tests
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
} cleave ;
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
} cleave ;
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
nip 2 fixnum+fast
] [
drop {
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
} cleave
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
! The above don't really test spilling...
: spill-test-1 ( a -- b )
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast fixnum>float
3array
3array [ 8 narray ] dip 2array
[ 8 narray [ 8 narray ] dip 2array ] dip 2array
2array ;
[
{
1
{
{ { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
{
{ 18 19 20 21 22 23 24 25 }
{ 26 27 { 28 29 30.0 } }
}
}
}
] [ 1 spill-test-1 ] unit-test
: spill-test-2 ( a -- b )
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float* ;
[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test

163
basis/compiler/tests/templates.factor
View File

@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors ;
combinators vectors float-arrays ;
IN: compiler.tests
! Originally, this file did black box testing of templating
@ -206,167 +206,6 @@ TUPLE: my-tuple ;
] compile-call
] unit-test
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
} cleave ;
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
} cleave ;
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
nip 2 fixnum+fast
] [
drop {
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
} cleave
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare

2
basis/compiler/tree/propagation/info/info.factor
View File

@ -307,5 +307,5 @@ SYMBOL: value-infos
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
dup in-d>> peek node-value-info
literal>> class>> immutable-tuple-class?
literal>> first immutable-tuple-class?
] [ drop f ] if ;

2
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -131,7 +131,7 @@ DEFER: (flat-length)
] bi* + + + + + ;
: should-inline? ( #call word -- ? )
inlining-rank 5 >= ;
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -281,7 +281,7 @@ generic-comparison-ops [
{ <tuple> <tuple-boa> } [
[
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
[ clear ] dip
] "outputs" set-word-prop
] each

2
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -379,7 +379,7 @@ TUPLE: mutable-tuple-test { x sequence } ;
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test
[ V{ tuple-layout } ] [
[ V{ array } ] [
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
] unit-test

2
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -45,7 +45,7 @@ UNION: fixed-length-sequence array byte-array string ;
: propagate-<tuple-boa> ( #call -- info )
in-d>> unclip-last
value-info literal>> class>> (propagate-tuple-constructor) ;
value-info literal>> first (propagate-tuple-constructor) ;
: propagate-<complex> ( #call -- info )
in-d>> [ value-info ] map complex <tuple-info> ;

2
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: concurrency.mailboxes
USING: dlists deques threads sequences continuations
destructors namespaces random math quotations words kernel
destructors namespaces math quotations words kernel
arrays assocs init system concurrency.conditions accessors
debugger debugger.threads locals ;

4
basis/concurrency/messaging/messaging.factor
View File

@ -4,7 +4,7 @@
! Concurrency library for Factor, based on Erlang/Termite style
! concurrency.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs random accessors summary ;
namespaces assocs accessors summary ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
@ -40,7 +40,7 @@ M: thread send ( message thread -- )
TUPLE: synchronous data sender tag ;
: <synchronous> ( data -- sync )
self 256 random-bits synchronous boa ;
self synchronous counter synchronous boa ;
TUPLE: reply data tag ;

2
basis/cpu/architecture/architecture.factor
View File

@ -58,6 +58,8 @@ HOOK: %slot-imm cpu ( dst obj slot tag -- )
HOOK: %set-slot cpu ( src obj slot tag temp -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %string-nth cpu ( dst obj index temp -- )
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
HOOK: %sub cpu ( dst src1 src2 -- )

4
basis/cpu/ppc/bootstrap.factor
View File

@ -11,8 +11,8 @@ big-endian on
4 jit-code-format set
: ds-reg 30 ;
: rs-reg 31 ;
: ds-reg 29 ;
: rs-reg 30 ;
: factor-area-size ( -- n ) 4 bootstrap-cells ;

259
basis/cpu/ppc/ppc.factor
View File

@ -1,28 +1,18 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types
accessors
cpu.architecture
compiler.cfg.registers
cpu.ppc.assembler
kernel
locals
layouts
combinators
make
compiler.cfg.instructions
math.order
system
math
compiler.constants
namespaces compiler.codegen.fixup ;
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.c-types cpu.architecture cpu.ppc.assembler
compiler.cfg.registers compiler.cfg.instructions
compiler.constants compiler.codegen compiler.codegen.fixup
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
IN: cpu.ppc
! PowerPC register assignments:
! r2-r28: integer vregs
! r29: integer scratch
! r30: data stack
! r31: retain stack
! r2-r27: integer vregs
! r28: integer scratch
! r29: data stack
! r30: retain stack
! f0-f29: float vregs
! f30, f31: float scratch
@ -36,17 +26,21 @@ IN: cpu.ppc
t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type (>>stack-align?)
] }
} cond >>
} cond
enable-float-intrinsics
\ ##integer>float t frame-required? set-word-prop
\ ##float>integer t frame-required? set-word-prop >>
M: ppc machine-registers
{
{ int-regs T{ range f 2 27 1 } }
{ double-float-regs T{ range f 0 28 1 } }
{ int-regs T{ range f 2 26 1 } }
{ double-float-regs T{ range f 0 29 1 } }
} ;
: scratch-reg 29 ; inline
: fp-scratch-reg-1 30 ; inline
: fp-scratch-reg-2 31 ; inline
: scratch-reg 28 ; inline
: fp-scratch-reg 30 ; inline
M: ppc two-operand? f ;
@ -57,13 +51,13 @@ M:: ppc %load-indirect ( reg obj -- )
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
: ds-reg 30 ; inline
: rs-reg 31 ; inline
: ds-reg 29 ; inline
: rs-reg 30 ; inline
GENERIC: loc-reg ( loc -- reg )
M: ds-loc log-reg drop ds-reg ;
M: rs-loc log-reg drop rs-reg ;
M: ds-loc loc-reg drop ds-reg ;
M: rs-loc loc-reg drop rs-reg ;
: loc>operand ( loc -- reg n )
[ loc-reg ] [ n>> cells neg ] bi ; inline
@ -82,12 +76,15 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
{ macosx [ 6 ] }
} case cells ; foldable
: lr-save ( -- n )
os {
{ linux [ 1 ] }
{ macosx [ 2 ] }
} case cells ; foldable
! The start of the stack frame contains the size of this frame
! as well as the currently executing XT
: factor-area-size ( -- n ) 2 cells ; foldable
: next-save ( n -- i ) cell - ;
: xt-save ( n -- i ) 2 cells - ;
! Next, we have the spill area as well as the FFI parameter area.
! They overlap, since basic blocks with FFI calls will never
! spill.
: param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable
@ -95,19 +92,38 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: factor-area-size ( -- n ) 2 cells ; foldable
: spill-integer-base ( -- n )
stack-frame get spill-counts>> double-float-regs swap at
double-float-regs reg-size * ;
: next-save ( n -- i ) cell - ;
: spill-integer@ ( n -- offset )
cells spill-integer-base + param@ ;
: xt-save ( n -- i ) 2 cells - ;
: spill-float@ ( n -- offset )
double-float-regs reg-size * param@ ;
! Some FP intrinsics need a temporary scratch area in the stack
! frame, 8 bytes in size
: scratch@ ( n -- offset )
stack-frame get total-size>>
factor-area-size -
param-save-size -
+ ;
! Finally we have the linkage area
: lr-save ( -- n )
os {
{ linux [ 1 ] }
{ macosx [ 2 ] }
} case cells ; foldable
M: ppc stack-frame-size ( stack-frame -- i )
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
[ params>> ]
[ return>> ]
tri + +
reserved-area-size +
param-save-size +
reserved-area-size +
factor-area-size +
4 cells align ;
@ -137,9 +153,25 @@ M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
M:: ppc %string-nth ( dst src index temp -- )
[
"end" define-label
temp src index ADD
dst temp string-offset LBZ
temp src string-aux-offset LWZ
0 temp \ f tag-number CMPI
"end" get BEQ
temp temp index ADD
temp temp index ADD
temp temp byte-array-offset LHZ
temp temp 8 SLWI
dst dst temp OR
"end" resolve-label
] with-scope ;
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swapd SUBF ;
M: ppc %sub swap SUBF ;
M: ppc %sub-imm SUBI ;
M: ppc %mul MULLW ;
M: ppc %mul-imm MULLI ;
@ -156,44 +188,42 @@ M: ppc %not NOT ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
M: ppc %integer>bignum ( dst src temp -- )
M:: ppc %integer>bignum ( dst src temp -- )
[
{ "end" "non-zero" "pos" "store" } [ define-label ] each
dst 0 >bignum %load-immediate
"end" define-label
dst 0 >bignum %load-indirect
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
! Allocate a bignum
dst 4 cells bignum temp %allot
! Write length
2 temp LI
dst 1 bignum@ temp STW
! Store value
dst 3 bignum@ src STW
2 tag-fixnum temp LI
temp dst 1 bignum@ STW
! Compute sign
temp src MR
temp cell-bits 1- SRAWI
temp temp cell-bits 1- SRAWI
temp temp 1 ANDI
! Store sign
dst 2 bignum@ temp STW
temp dst 2 bignum@ STW
! Make negative value positive
temp temp temp ADD
temp temp NEG
temp temp 1 ADDI
temp src temp MULLW
! Store the bignum
dst 3 bignum@ temp STW
temp dst 3 bignum@ STW
"end" resolve-label
] with-scope ;
M:: %bignum>integer ( dst src temp -- )
M:: ppc %bignum>integer ( dst src temp -- )
[
"end" define-label
temp src 1 bignum@ LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 dst LI
0 temp 1 v>operand CMPI
0 temp 1 tag-fixnum CMPI
"end" get BEQ
! load the value
dst src 3 bignum@ LWZ
@ -203,6 +233,7 @@ M:: %bignum>integer ( dst src temp -- )
! and 1 into -1
temp temp temp ADD
temp temp 1 SUBI
temp temp NEG
! multiply value by sign
dst dst temp MULLW
"end" resolve-label
@ -213,28 +244,32 @@ M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
M: ppc %integer>float ( dst src -- )
M:: ppc %integer>float ( dst src -- )
HEX: 4330 scratch-reg LIS
scratch-reg 1 0 param@ STW
scratch-reg 1 0 scratch@ STW
scratch-reg src MR
scratch-reg dup HEX: 8000 XORIS
scratch-reg 1 cell param@ STW
fp-scratch-reg-2 1 0 param@ LFD
4503601774854144.0 scratch-reg load-indirect
fp-scratch-reg-2 scratch-reg float-offset LFD
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
scratch-reg 1 4 scratch@ STW
dst 1 0 scratch@ LFD
scratch-reg 4503601774854144.0 %load-indirect
fp-scratch-reg scratch-reg float-offset LFD
dst dst fp-scratch-reg FSUB ;
M:: ppc %float>integer ( dst src -- )
fp-scratch-reg-1 src FCTIWZ
fp-scratch-reg-2 1 0 param@ STFD
dst 1 4 param@ LWZ ;
fp-scratch-reg src FCTIWZ
fp-scratch-reg 1 0 scratch@ STFD
dst 1 4 scratch@ LWZ ;
M: ppc %copy ( dst src -- ) MR ;
M: ppc %copy-float ( dst src -- ) MFR ;
M: ppc %copy-float ( dst src -- ) FMR ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
M:: ppc %box-float ( dst src temp -- )
dst 16 float temp %allot
src dst float-offset STFD ;
M:: ppc %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
@ -277,9 +312,9 @@ M:: ppc %box-alien ( dst src temp -- )
"f" get BEQ
dst 4 cells alien temp %allot
! Store offset
dst src 3 alien@ STW
temp \ f tag-number %load-immediate
src dst 3 alien@ STW
! Store expired slot
temp \ f tag-number %load-immediate
temp dst 1 alien@ STW
! Store underlying-alien slot
temp dst 2 alien@ STW
@ -289,7 +324,7 @@ M:: ppc %box-alien ( dst src temp -- )
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;
M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
M: ppc %alien-signed-2 0 LHA ;
M: ppc %alien-cell 0 LWZ ;
@ -297,45 +332,47 @@ M: ppc %alien-cell 0 LWZ ;
M: ppc %alien-float 0 LFS ;
M: ppc %alien-double 0 LFD ;
M: ppc %set-alien-integer-1 0 STB ;
M: ppc %set-alien-integer-2 0 STH ;
M: ppc %set-alien-integer-1 swap 0 STB ;
M: ppc %set-alien-integer-2 swap 0 STH ;
M: ppc %set-alien-cell 0 STW ;
M: ppc %set-alien-cell swap 0 STW ;
M: ppc %set-alien-float 0 STFS ;
M: ppc %set-alien-double 0 STFD ;
M: ppc %set-alien-float swap 0 STFS ;
M: ppc %set-alien-double swap 0 STFD ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
: load-zone-ptr ( reg -- )
[ "nursery" f ] dip %load-dlsym ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr n -- )
scratch-reg inc-allot-ptr 4 LWZ
scratch-reg scratch-reg n 8 align ADD
scratch-reg inc-allot-ptr 4 STW ;
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
scratch-reg allot-ptr n 8 align ADDI
scratch-reg nursery-ptr 4 STW ;
:: store-header ( temp class -- )
:: store-header ( dst class -- )
class type-number tag-fixnum scratch-reg LI
temp scratch-reg 0 STW ;
scratch-reg dst 0 STW ;
: store-tagged ( dst tag -- )
dupd tag-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
nursery-ptr dst size inc-allot-ptr
dst class store-header
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
dst class store-tagged ;
: %alien-global ( dest name -- )
[ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: %alien-global ( dst name -- )
[ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: load-cards-offset ( dest -- )
: load-cards-offset ( dst -- )
"cards_offset" %alien-global ;
: load-decks-offset ( dest -- )
: load-decks-offset ( dst -- )
"decks_offset" %alien-global ;
M:: ppc %write-barrier ( src card# table -- )
@ -359,18 +396,17 @@ M: ppc %gc
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
M: ppc %prologue ( n -- )
0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
1 1 pick neg ADDI
scrach-reg 1 pick xt-save STW
dup scrach-reg LI
scrach-reg 1 pick next-save STW
11 1 pick xt-save STW
dup 11 LI
11 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc %epilogue ( n -- )
@ -384,19 +420,19 @@ M: ppc %epilogue ( n -- )
:: (%boolean) ( dst word -- )
"end" define-label
\ f tag-number %load-immediate
dst \ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
: %boolean ( dst cc -- )
negate-cc {
{ cc< [ \ BLT %boolean ] }
{ cc<= [ \ BLE %boolean ] }
{ cc> [ \ BGT %boolean ] }
{ cc>= [ \ BGE %boolean ] }
{ cc= [ \ BEQ %boolean ] }
{ cc/= [ \ BNE %boolean ] }
{ cc< [ \ BLT (%boolean) ] }
{ cc<= [ \ BLE (%boolean) ] }
{ cc> [ \ BGT (%boolean) ] }
{ cc>= [ \ BGE (%boolean) ] }
{ cc= [ \ BEQ (%boolean) ] }
{ cc/= [ \ BNE (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
@ -421,32 +457,11 @@ M: ppc %compare-branch (%compare) %branch ;
M: ppc %compare-imm-branch (%compare-imm) %branch ;
M: ppc %compare-float-branch (%compare-float) %branch ;
: spill-integer-base ( stack-frame -- n )
[ params>> ] [ return>> ] bi + ;
M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
: stack@ 1 swap ; inline
: spill-integer@ ( n -- op )
cells
stack-frame get spill-integer-base
+ stack@ ;
: spill-float-base ( stack-frame -- n )
[ spill-counts>> int-regs swap at int-regs reg-size * ]
[ params>> ]
[ return>> ]
tri + + ;
: spill-float@ ( n -- op )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
M: ppc %loop-entry ;
@ -560,7 +575,7 @@ M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke

2
basis/cpu/x86/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
compiler

48
basis/cpu/x86/x86.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
@ -278,27 +278,47 @@ M:: x86 %box-alien ( dst src temp -- )
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
: small-reg-that-isn't ( exclude -- reg' )
small-reg-4 small-regs [ eq? not ] with find nip ;
small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
: with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
:: with-small-register ( dst src quot: ( dst src -- ) -- )
:: with-small-register ( dst exclude quot: ( new-dst -- ) -- )
#! If the destination register overlaps a small register, we
#! call the quot with that. Otherwise, we find a small
#! register that is not equal to src, and call quot, saving
#! register that is not in exclude, and call quot, saving
#! and restoring the small register.
dst small-reg-4 small-regs memq? [ dst src quot call ] [
src small-reg-that-isn't
[| new-dst |
new-dst src quot call
dst new-dst MOV
] with-save/restore
dst small-reg-4 small-regs memq? [ dst quot call ] [
exclude small-reg-that-isn't
[ quot call ] with-save/restore
] if ; inline
: %alien-integer-getter ( dst src size quot -- )
'[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
with-small-register ; inline
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
temp src string-aux-offset [+] MOV
temp \ f tag-number CMP
"end" get JE
new-dst temp XCHG
new-dst index ADD
new-dst index ADD
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
new-dst new-dst 2 small-reg MOVZX
new-dst 8 SHL
new-dst temp OR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
:: %alien-integer-getter ( dst src size quot -- )
dst { src } [| new-dst |
new-dst dup size small-reg dup src [] MOV
quot call
dst new-dst ?MOV
] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
[ MOVZX ] %alien-integer-getter ; inline
@ -320,7 +340,7 @@ M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
M: x86 %alien-double [] MOVSD ;
:: %alien-integer-setter ( ptr value size -- )
value ptr [| new-value ptr |
value { ptr } [| new-value |
new-value value ?MOV
ptr [] new-value size small-reg MOV
] with-small-register ; inline

3
basis/help/handbook/handbook.factor
View File

@ -86,14 +86,11 @@ ARTICLE: "objects" "Objects"
{ $subsection "slots" }
{ $subsection "mirrors" } ;
USE: random
ARTICLE: "numbers" "Numbers"
{ $subsection "arithmetic" }
{ $subsection "math-constants" }
{ $subsection "math-functions" }
{ $subsection "number-strings" }
{ $subsection "random" }
"Number implementations:"
{ $subsection "integers" }
{ $subsection "rationals" }

4
basis/hints/hints.factor
View File

@ -64,10 +64,12 @@ IN: hints
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
{ peek pop* pop push } [
{ peek pop* pop } [
{ vector } "specializer" set-word-prop
] each
\ push { { vector } { sbuf } } "specializer" set-word-prop
\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop

13
basis/io/buffers/buffers.factor
View File

@ -36,9 +36,7 @@ M: buffer dispose* ptr>> free ;
[ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
: buffer-pop ( buffer -- byte )
[ buffer-peek ] [ 1 swap buffer-consume ] bi ;
HINTS: buffer-pop buffer ;
[ buffer-peek ] [ 1 swap buffer-consume ] bi ; inline
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ; inline
@ -69,14 +67,13 @@ HINTS: n>buffer fixnum buffer ;
HINTS: >buffer byte-array buffer ;
: byte>buffer ( byte buffer -- )
[ >fixnum ] dip
[ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
[ 1 swap n>buffer ]
bi ;
HINTS: byte>buffer fixnum buffer ;
bi ; inline
: search-buffer-until ( pos fill ptr separators -- n )
[ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
[ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; inline
: finish-buffer-until ( buffer n -- byte-array separator )
[
@ -86,7 +83,7 @@ HINTS: byte>buffer fixnum buffer ;
] [
[ buffer-length ] keep
buffer-read f
] if* ;
] if* ; inline
: buffer-until ( separators buffer -- byte-array separator )
swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip

2
basis/io/encodings/ascii/ascii.factor
View File

@ -9,7 +9,7 @@ IN: io.encodings.ascii
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
[ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
[ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii

8
basis/io/ports/ports.factor
View File

@ -39,7 +39,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
M: input-port stream-read1
dup check-disposed
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
: read-step ( count port -- byte-array/f )
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
@ -100,12 +100,12 @@ TUPLE: output-port < buffered-port ;
: wait-to-write ( len port -- )
tuck buffer>> buffer-capacity <=
[ drop ] [ stream-flush ] if ;
[ drop ] [ stream-flush ] if ; inline
M: output-port stream-write1
dup check-disposed
1 over wait-to-write
buffer>> byte>buffer ;
buffer>> byte>buffer ; inline
M: output-port stream-write
dup check-disposed
@ -161,4 +161,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii }
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;

8
basis/io/streams/memory/memory.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors alien.accessors math io ;
USING: kernel accessors alien alien.c-types alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
@ -11,3 +11,9 @@ TUPLE: memory-stream alien index ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;

9
basis/locals/locals-tests.factor
View File

@ -1,7 +1,8 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions ;
combinators.short-circuit.smart math.order math.functions
definitions compiler.units ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -378,6 +379,12 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ 9 ] [ 3 big-case-test ] unit-test
GENERIC: lambda-method-forget-test ( a -- b )
M:: integer lambda-method-forget-test ( a -- b ) ;
[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]

2
basis/locals/locals.factor
View File

@ -450,7 +450,7 @@ M: lambda-method definition
"lambda" word-prop body>> ;
M: lambda-method reset-word
[ f "lambda" set-word-prop ] [ call-next-method ] bi ;
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-memoized memoized lambda-word ;

2
basis/math/intervals/intervals-tests.factor
View File

@ -83,8 +83,6 @@ IN: math.intervals.tests
0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
] unit-test
[ f ] [ 0 1 (a,b) f interval-union ] unit-test
[ t ] [
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
] unit-test

21
basis/math/intervals/intervals.factor
View File

@ -115,14 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ;
{ [ dup empty-interval eq? ] [ nip ] }
{ [ over empty-interval eq? ] [ drop ] }
[
2dup and [
[ interval>points ] bi@ swapd
[ [ swap endpoint< ] most ]
[ [ swap endpoint> ] most ] 2bi*
<interval>
] [
or
] if
[ interval>points ] bi@ swapd
[ [ swap endpoint< ] most ]
[ [ swap endpoint> ] most ] 2bi*
<interval>
]
} cond ;
@ -133,13 +129,7 @@ TUPLE: interval { from read-only } { to read-only } ;
{
{ [ dup empty-interval eq? ] [ drop ] }
{ [ over empty-interval eq? ] [ nip ] }
[
2dup and [
[ interval>points 2array ] bi@ append points>interval
] [
2drop f
] if
]
[ [ interval>points 2array ] bi@ append points>interval ]
} cond ;
: interval-subset? ( i1 i2 -- ? )
@ -183,7 +173,6 @@ TUPLE: interval { from read-only } { to read-only } ;
: interval-length ( int -- n )
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
{ [ dup not ] [ drop 0 ] }
[ interval>points [ first ] bi@ swap - ]
} cond ;

2
basis/mirrors/mirrors.factor
View File

@ -44,7 +44,7 @@ M: mirror >alist ( mirror -- alist )
[ object>> [ swap slot ] curry ] bi
map zip ;
M: mirror assoc-size object>> layout-of size>> ;
M: mirror assoc-size object>> layout-of second ;
INSTANCE: mirror assoc

3
basis/prettyprint/backend/backend.factor
View File

@ -233,6 +233,3 @@ M: wrapper pprint*
] [
pprint-object
] if ;
M: tuple-layout pprint*
"( tuple layout )" swap present-text ;

7
basis/random/mersenne-twister/mersenne-twister.factor
View File

@ -68,3 +68,10 @@ M: mersenne-twister random-32* ( mt -- r )
[ next-index ]
[ seq>> nth mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
USE: init
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
] "bootstrap.random" add-init-hook

9
basis/random/random.factor
View File

@ -60,3 +60,12 @@ PRIVATE>
: with-secure-random ( quot -- )
secure-random-generator get swap with-random ; inline
USE: vocabs.loader
{
{ [ os windows? ] [ "random.windows" require ] }
{ [ os unix? ] [ "random.unix" require ] }
} cond
"random.mersenne-twister" require

44
basis/regexp/parser/parser.factor
View File

@ -233,15 +233,22 @@ ERROR: invalid-range a b ;
SINGLETON: beginning-of-input
SINGLETON: end-of-input
! : beginning-of-input ( -- obj )
: handle-front-anchor ( -- ) front-anchor push-stack ;
: end-of-line ( -- obj )
end-of-input
: newlines ( -- obj1 obj2 obj3 )
CHAR: \r <constant>
CHAR: \n <constant>
2dup 2array <concatenation> 4array <alternation> lookahead boa ;
2dup 2array <concatenation> ;
: handle-back-anchor ( -- ) end-of-line push-stack ;
: beginning-of-line ( -- obj )
beginning-of-input newlines 4array <alternation> lookbehind boa ;
: end-of-line ( -- obj )
end-of-input newlines 4array <alternation> lookahead boa ;
: handle-front-anchor ( -- )
get-multiline beginning-of-line beginning-of-input ? push-stack ;
: handle-back-anchor ( -- )
get-multiline end-of-line end-of-input ? push-stack ;
ERROR: bad-character-class obj ;
ERROR: expected-posix-class ;
@ -412,16 +419,11 @@ DEFER: handle-left-bracket
[ [ push ] keep current-regexp get (>>stack) ]
[ finish-regexp-parse push-stack ] bi* ;
: parse-regexp-token ( token -- ? )
{
! todo: only match these at beginning/end of regexp
{ CHAR: ^ [ handle-front-anchor t ] }
{ CHAR: $ [ handle-back-anchor t ] }
{ CHAR: . [ handle-dot t ] }
{ CHAR: ( [ handle-left-parenthesis t ] }
{ CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
{ CHAR: ) [ handle-right-parenthesis f ] }
{ CHAR: . [ handle-dot t ] }
{ CHAR: | [ handle-pipe t ] }
{ CHAR: ? [ handle-question t ] }
{ CHAR: * [ handle-star t ] }
@ -429,16 +431,28 @@ DEFER: handle-left-bracket
{ CHAR: { [ handle-left-brace t ] }
{ CHAR: [ [ handle-left-bracket t ] }
{ CHAR: \ [ handle-escape t ] }
[ <constant> push-stack t ]
[
dup CHAR: $ = peek1 f = and [
drop
handle-back-anchor f
] [
<constant> push-stack t
] if
]
} case ;
: (parse-regexp) ( -- )
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
: parse-regexp-beginning ( -- )
peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
: parse-regexp ( regexp -- )
dup current-regexp [
raw>> [
<string-reader> [ (parse-regexp) ] with-input-stream
<string-reader> [
parse-regexp-beginning (parse-regexp)
] with-input-stream
] unless-empty
current-regexp get
stack finish-regexp-parse

1
basis/regexp/regexp-tests.factor
View File

@ -331,4 +331,3 @@ IN: regexp-tests
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test

2
basis/regexp/regexp.factor
View File

@ -92,7 +92,6 @@ IN: regexp
reversed-regexp initial-option
construct-regexp ;
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
@ -112,7 +111,6 @@ IN: regexp
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
: find-regexp-syntax ( string -- prefix suffix )
{
{ "R/ " "/" }

11
basis/regexp/traversal/traversal.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math math.ranges
quotations sequences regexp.parser regexp.classes fry arrays
combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
combinators.short-circuit regexp.utils prettyprint regexp.nfa
shuffle ;
IN: regexp.traversal
TUPLE: dfa-traverser
@ -23,8 +24,7 @@ TUPLE: dfa-traverser
[ dfa-table>> ] [ dfa-traversal-flags>> ] bi
dfa-traverser new
swap >>traversal-flags
swap [ start-state>> >>current-state ] keep
>>dfa-table
swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
swap >>text
t >>traverse-forward
0 >>start-index
@ -116,7 +116,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
V{ } clone >>matches ;
: match-literal ( transition from-state table -- to-state/f )
transitions>> at* [ at ] [ 2drop f ] if ;
transitions>> at at ;
: match-class ( transition from-state table -- to-state/f )
transitions>> at* [
@ -124,8 +124,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
] [ drop ] if ;
: match-default ( transition from-state table -- to-state/f )
[ nip ] dip transitions>> at*
[ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
nipd transitions>> at t swap at ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;

5
basis/stack-checker/known-words/known-words.factor
View File

@ -108,7 +108,7 @@ M: object infer-call*
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
peek-d literal value>> size>> 1+ { tuple } <effect>
peek-d literal value>> second 1+ { tuple } <effect>
apply-word/effect ;
: infer-(throw) ( -- )
@ -561,9 +561,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ <tuple> { tuple-layout } { tuple } define-primitive
\ <tuple> make-flushable
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
\ <tuple-layout> make-foldable
\ datastack { } { array } define-primitive
\ datastack make-flushable

2
basis/tools/deploy/backend/backend.factor
View File

@ -42,7 +42,7 @@ IN: tools.deploy.backend
{ "compiler" deploy-compiler? }
{ "threads" deploy-threads? }
{ "ui" deploy-ui? }
{ "random" deploy-random? }
{ "unicode" deploy-unicode? }
} [ nip get ] assoc-filter keys
native-io? [ "io" suffix ] when ;

8
basis/tools/deploy/config/config-docs.factor
View File

@ -16,7 +16,7 @@ ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiler? }
{ $subsection deploy-random? }
{ $subsection deploy-unicode? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
@ -73,10 +73,10 @@ HELP: deploy-compiler?
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
HELP: deploy-random?
{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
HELP: deploy-unicode?
{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
$nl
"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
"Off by default. If your program needs to use " { $link POSTPONE: CHAR: } " with named characters, enable this flag." } ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, thread support will be included in the final image."

4
basis/tools/deploy/config/config.factor
View File

@ -10,7 +10,7 @@ SYMBOL: deploy-name
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
SYMBOL: deploy-random?
SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
SYMBOL: deploy-io
@ -58,7 +58,7 @@ SYMBOL: deploy-image
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? t }
{ deploy-random? t }
{ deploy-unicode? f }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }

1
basis/tools/deploy/test/1/deploy.factor
View File

@ -1,7 +1,6 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }

1
basis/tools/deploy/test/2/deploy.factor
View File

@ -1,7 +1,6 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }

1
basis/tools/deploy/test/3/deploy.factor
View File

@ -1,7 +1,6 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }

1
basis/tools/deploy/test/4/deploy.factor
View File

@ -1,7 +1,6 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }

1
basis/tools/deploy/test/5/deploy.factor
View File

@ -1,7 +1,6 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }

1
basis/tools/deploy/test/6/deploy.factor
View File

@ -5,7 +5,6 @@ H{
{ deploy-io 1 }
{ deploy-name "tools.deploy.test.6" }
{ deploy-math? t }
{ deploy-random? f }
{ deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }

2
basis/ui/tools/deploy/deploy.factor
View File

@ -36,7 +36,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> add-gadget
deploy-random? get "Random number generator support" <checkbox> add-gadget
deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;

5
core/bootstrap/layouts/layouts.factor
View File

@ -9,7 +9,7 @@ BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
18 num-types set
17 num-types set
H{
{ fixnum BIN: 000 }
@ -29,9 +29,8 @@ tag-numbers get H{
{ byte-array 10 }
{ callstack 11 }
{ string 12 }
{ tuple-layout 13 }
{ word 13 }
{ quotation 14 }
{ dll 15 }
{ alien 16 }
{ word 17 }
} assoc-union type-numbers set

10
core/bootstrap/primitives.factor
View File

@ -147,7 +147,6 @@ bootstrapping? on
"alien" "alien" create register-builtin
"word" "words" create register-builtin
"byte-array" "byte-arrays" create register-builtin
"tuple-layout" "classes.tuple.private" create register-builtin
! For predicate classes
"predicate-instance?" "classes.predicate" create drop
@ -272,14 +271,6 @@ bi
"callstack" "kernel" create { } define-builtin
"tuple-layout" "classes.tuple.private" create {
{ "hashcode" { "fixnum" "math" } read-only }
{ "class" { "word" "words" } initial: t read-only }
{ "size" { "fixnum" "math" } read-only }
{ "superclasses" { "array" "arrays" } initial: { } read-only }
{ "echelon" { "fixnum" "math" } read-only }
} define-builtin
"tuple" "kernel" create
[ { } define-builtin ]
[ define-tuple-layout ]
@ -510,7 +501,6 @@ tuple
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "classes.tuple.private" }
{ "<tuple-layout>" "classes.tuple.private" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }

3
core/bootstrap/stage1.factor
View File

@ -49,4 +49,5 @@ load-help? off
1 exit
] if
] %
] [ ] make bootstrap-boot-quot set
] [ ] make
bootstrap-boot-quot set

8
core/classes/algebra/algebra.factor
View File

@ -20,6 +20,14 @@ C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
GENERIC: valid-class? ( obj -- ? )
M: class valid-class? drop t ;
M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
M: anonymous-complement valid-class? class>> valid-class? ;
M: word valid-class? drop f ;
DEFER: (class<=)
: class<= ( first second -- ? )

34
core/classes/classes-tests.factor
View File

@ -79,3 +79,37 @@ USE: multiline
: q ( -- b ) j new g ;"> <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Similar problem, but with anonymous classes
[ ] [
<" IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
TUPLE: z ;"> <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
[ ] [
<" IN: classes.test.d
USE: classes.test.c
USE: kernel
: q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
"class-intersect-no-method-d" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
<" IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
TUPLE: j ;
M: j g ;"> <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
TUPLE: forgotten-predicate-test ;
[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test

24
core/classes/classes.factor
View File

@ -32,8 +32,7 @@ SYMBOL: update-map
SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: class < word "class" word-prop ;
: classes ( -- seq ) implementors-map get keys ;
@ -42,9 +41,12 @@ PREDICATE: class < word
PREDICATE: predicate < word "predicating" word-prop >boolean ;
M: predicate reset-word
[ call-next-method ] [ { "predicating" } reset-props ] bi ;
: define-predicate ( class quot -- )
>r "predicate" word-prop first
r> (( object -- ? )) define-declared ;
[ "predicate" word-prop first ] dip
(( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
@ -121,13 +123,13 @@ M: sequence implementors [ implementors ] gather ;
] H{ } make-assoc ;
: (define-class) ( word props -- )
>r
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup redefined
dup props>>
r> assoc-union >>props
[
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup redefined
dup props>>
] dip assoc-union >>props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]

6
core/classes/tuple/tuple-docs.factor
View File

@ -348,7 +348,7 @@ $nl
{ $list
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
{ { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
{ { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" }
} } ;
HELP: define-tuple-predicate
@ -405,11 +405,11 @@ HELP: tuple>array ( tuple -- array )
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
{ $values { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: new

8
core/classes/tuple/tuple-tests.factor
View File

@ -94,7 +94,7 @@ TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } tuple-size
size-test tuple-layout size>> =
size-test tuple-layout second =
] unit-test
GENERIC: <yo-momma>
@ -238,12 +238,6 @@ C: <laptop> laptop
test-laptop-slot-values
[ laptop ] [
"laptop" get 1 slot
dup echelon>> swap
superclasses>> nth
] unit-test
[ "TUPLE: laptop < computer battery ;" ] [
[ \ laptop see ] with-string-writer string-lines second
] unit-test

53
core/classes/tuple/tuple.factor
View File

@ -10,8 +10,6 @@ IN: classes.tuple
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
@ -29,10 +27,12 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
"layout" word-prop ;
: layout-of ( tuple -- layout )
1 slot { tuple-layout } declare ; inline
1 slot { array } declare ; inline
M: tuple class layout-of 2 slot { word } declare ;
: tuple-size ( tuple -- size )
layout-of size>> ; inline
layout-of second ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
@ -59,7 +59,7 @@ PRIVATE>
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
class>> prefix ;
first prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
@ -90,16 +90,29 @@ ERROR: bad-superclass class ;
2drop f
] if ; inline
: tuple-instance? ( object class echelon -- ? )
#! 4 slot == superclasses>>
: tuple-instance-1? ( object class -- ? )
swap dup tuple? [
layout-of 7 slot eq?
] [ 2drop f ] if ; inline
: tuple-instance? ( object class offset -- ? )
rot dup tuple? [
layout-of 4 slot { array } declare
2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if
layout-of
2dup 1 slot fixnum<=
[ swap slot eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
: layout-class-offset ( echelon -- n )
2 * 5 + ;
: echelon-of ( class -- n )
tuple-layout third ;
: define-tuple-predicate ( class -- )
dup dup tuple-layout echelon>>
[ tuple-instance? ] 2curry define-predicate ;
dup dup echelon-of {
{ 1 [ [ tuple-instance-1? ] curry ] }
[ layout-class-offset [ tuple-instance? ] 2curry ]
} case define-predicate ;
: class-size ( class -- n )
superclasses [ "slots" word-prop length ] sigma ;
@ -145,10 +158,14 @@ ERROR: bad-superclass class ;
define-accessors ;
: make-tuple-layout ( class -- layout )
[ ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
[
{
[ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
[ superclasses length 1- , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave
] { } make ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
@ -169,13 +186,13 @@ ERROR: bad-superclass class ;
[ first3 update-slot ] with map ;
: permute-slots ( old-values layout -- new-values )
[ class>> all-slots ] [ outdated-tuples get at ] bi
[ first all-slots ] [ outdated-tuples get at ] bi
compute-slot-permutation
apply-slot-permutation ;
: update-tuple ( tuple -- newtuple )
[ tuple-slots ] [ layout-of ] bi
[ permute-slots ] [ class>> ] bi
[ permute-slots ] [ first ] bi
slots>tuple ;
: outdated-tuple? ( tuple assoc -- ? )
@ -284,7 +301,7 @@ M: tuple-class reset-class
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ;
dup echelon-of layout-class-offset tuple-instance? ;
M: tuple-class (flatten-class) dup set ;

2
core/compiler/units/units.factor
View File

@ -111,7 +111,7 @@ SYMBOL: remake-generics-hook
: (compiled-generic-usages) ( generic class -- assoc )
[ compiled-generic-usage ] dip
[
2dup [ class? ] both?
2dup [ valid-class? ] both?
[ classes-intersect? ] [ 2drop f ] if nip
] curry assoc-filter ;

12
core/generic/parser/parser.factor
View File

@ -8,7 +8,7 @@ ERROR: not-in-a-method-error ;
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
: create-method-in ( class generic -- method )
create-method f set-word dup save-location ;
create-method dup set-word dup save-location ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
@ -18,11 +18,11 @@ SYMBOL: current-generic
: with-method-definition ( quot -- parsed )
[
>r
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
r> call
[
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
] dip call
] with-scope ; inline
: (M:) ( method def -- )

6
core/generic/standard/engines/tag/tag.factor
View File

@ -3,7 +3,7 @@
USING: classes.private generic.standard.engines namespaces make
arrays assocs sequences.private quotations kernel.private
math slots.private math.private kernel accessors words
layouts ;
layouts sorting sequences ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
@ -23,9 +23,11 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
] if ;
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
methods>> engines>quots*
[ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
>alist sort-keys reverse
linear-dispatch-quot
] [
num-tags get direct-dispatch-quot

127
core/generic/standard/engines/tuple/tuple.factor
View File

@ -7,18 +7,28 @@ 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 methods ;
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 -- )
>r swap dup "layout" word-prop echelon>> r>
[ swap dup "layout" word-prop third ] dip
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
@ -38,19 +48,24 @@ TUPLE: tuple-dispatch-engine echelons ;
\ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
methods>> engines>quots* linear-dispatch-quot ;
[ n>> ] [ methods>> ] bi dup assoc-empty? [
2drop default get [ drop ] prepend
] [
[
[ nth-superclass% ]
[ engines>quots* linear-dispatch-quot % ] bi*
] [ ] make
] if ;
: hash-methods ( methods -- buckets )
: hash-methods ( n methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
[ <trivial-tuple-dispatch-engine> ] with map ;
: word-hashcode% ( -- ) [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot )
: class-hash-dispatch-quot ( n methods -- quot )
[
\ dup ,
word-hashcode%
hash-methods [ engine>quot ] map hash-dispatch-quot %
[ drop nth-hashcode% ]
[ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
] [ ] make ;
: engine-word-name ( -- string )
@ -79,29 +94,16 @@ M: engine-word irrelevant? drop t ;
dup generic get "tuple-dispatch-generic" set-word-prop ;
: define-engine-word ( quot -- word )
>r <engine-word> dup r> define ;
: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare
] % ; inline
[ <engine-word> dup ] dip define ;
: tuple-dispatch-engine-body ( engine -- quot )
[
picker %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [
class-hash-dispatch-quot
] if-small? %
] bi
tuple-layout%
[ n>> ] [ methods>> ] bi
[ <trivial-tuple-dispatch-engine> engine>quot ]
[ class-hash-dispatch-quot ]
if-small? %
] [ ] make ;
M: echelon-dispatch-engine engine>quot
@ -109,22 +111,11 @@ M: echelon-dispatch-engine engine>quot
methods>> dup assoc-empty?
[ drop default get ] [ values first engine>quot ] if
] [
[
picker %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [
class-hash-dispatch-quot
] if-small? %
] bi
] [ ] make
tuple-dispatch-engine-body
] if ;
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
: >=-case-quot ( default alist -- quot )
[ [ drop ] prepend ] dip
[
[ [ dup ] swap [ fixnum>= ] curry compose ]
[ [ drop ] prepose ]
@ -132,31 +123,45 @@ M: echelon-dispatch-engine engine>quot
] assoc-map
alist>quot ;
: tuple-layout-echelon% ( -- )
: 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
[
{ tuple } declare
1 slot { tuple-layout } declare
5 slot
] % ; inline
[
picker %
tuple-layout%
tuple-layout-echelon%
>=-case-quot %
] [ ] make
] unless-empty ;
M: tuple-dispatch-engine engine>quot
[
picker %
tuple-layout-echelon%
[
tuple assumed set
echelons>> dup empty? [
unclip-last
echelons>> unclip-last
[
[
[
engine>quot define-engine-word
engine>quot
over 0 = [
define-engine-word
[ remember-engine ] [ 1quotation ] bi
dup default set
] assoc-map
]
[ first2 engine>quot 2array ] bi*
suffix
] unless
] unless
dup default set
] assoc-map
]
[ first2 engine>quot 2array ] bi*
suffix
] with-scope
>=-case-quot %
echelon-case-quot %
] [ ] make ;

29
core/generic/standard/standard.factor
View File

@ -60,21 +60,22 @@ ERROR: no-method object generic ;
[ 1quotation ] [ extra-values \ drop <repetition> ] bi*
prepend [ ] like ;
: <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
[ generic get mangle-method ] assoc-map
[ find-default default set ]
[ <big-dispatch-engine> ]
bi
]
} cleave ;
: single-combination ( word -- quot )
[
object bootstrap-word assumed set {
[ generic set ]
[ "engines" word-prop forget-all ]
[ V{ } clone "engines" set-word-prop ]
[
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
[ <big-dispatch-engine> ]
bi engine>quot
]
} cleave
] with-scope ;
[ <standard-engine> engine>quot ] with-scope ;
ERROR: inconsistent-next-method class generic ;

4
core/io/encodings/encodings.factor
View File

@ -124,11 +124,11 @@ M: object <encoder> encoder boa ;
M: encoder stream-write1
>encoder< encode-char ;
: decoder-write ( string stream encoding -- )
: encoder-write ( string stream encoding -- )
[ encode-char ] 2curry each ;
M: encoder stream-write
>encoder< decoder-write ;
>encoder< encoder-write ;
M: encoder dispose stream>> dispose ;

4
core/kernel/kernel.factor
View File

@ -167,11 +167,11 @@ GENERIC: boa ( ... class -- tuple )
compose compose ; inline
! Booleans
: not ( obj -- ? ) f t ? ; inline
: not ( obj -- ? ) [ f ] [ t ] if ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
: >boolean ( obj -- ? ) t f ? ; inline
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline

14
core/words/words.factor
View File

@ -204,13 +204,9 @@ GENERIC: reset-word ( word -- )
M: word reset-word
{
"unannotated-def"
"parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
"reader" "writer"
"constructing"
"declared-effect" "constructor-quot" "delimiter"
"unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader"
"writer" "declared-effect" "delimiter"
} reset-props ;
GENERIC: subwords ( word -- seq )
@ -261,12 +257,12 @@ M: word forget*
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
[ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
tri
] if ;
M: word hashcode*
nip 1 slot { fixnum } declare ;
nip 1 slot { fixnum } declare ; foldable
M: word literalize <wrapper> ;

22
extra/advice/advice-docs.factor Normal file
View File

@ -0,0 +1,22 @@
IN: advice
USING: help.markup help.syntax tools.annotations words ;
HELP: make-advised
{ $values { "word" "a word to annotate in preparation of advising" } }
{ $description "Prepares a word for being advised. This is done by: "
{ $list
{ "Annotating it to call the appropriate words before, around, and after the original body " }
{ "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
{ "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
}
}
{ $see-also advised? annotate } ;
HELP: advised?
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;
ARTICLE: "advice" "Advice"
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
ABOUT: "advice"

40
extra/advice/advice-tests.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math tools.test advice parser namespaces ;
IN: advice.tests
[
: foo "foo" ;
\ foo make-advised
{ "bar" "foo" } [
[ "bar" ] "barify" \ foo advise-before
foo ] unit-test
{ "bar" "foo" "baz" } [
[ "baz" ] "bazify" \ foo advise-after
foo ] unit-test
{ "foo" "baz" } [
"barify" \ foo before remove-advice
foo ] unit-test
: bar ( a -- b ) 1+ ;
\ bar make-advised
{ 11 } [
[ 2 * ] "double" \ bar advise-before
5 bar
] unit-test
{ 11/3 } [
[ 3 / ] "third" \ bar advise-after
5 bar
] unit-test
{ -2 } [
[ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
5 bar
] unit-test
] with-scope

49
extra/advice/advice.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
IN: advice
SYMBOLS: before after around advised ;
<PRIVATE
: advise ( quot name word loc -- )
word-prop set-at ;
PRIVATE>
: advise-before ( quot name word -- )
before advise ;
: advise-after ( quot name word -- )
after advise ;
: advise-around ( quot name word -- )
[ \ coterminate suffix ] 2dip
around advise ;
: get-advice ( word type -- seq )
word-prop values ;
: call-before ( word -- )
before get-advice [ call ] each ;
: call-after ( word -- )
after get-advice [ call ] each ;
: call-around ( main word -- )
around get-advice [ cocreate ] map tuck
[ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
: remove-advice ( name word loc -- )
word-prop delete-at ;
: ad-do-it ( input -- result )
coyield ;
: advised? ( word -- ? )
advised word-prop ;
: make-advised ( word -- )
[ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
[ { before after around } [ H{ } clone swap set-word-prop ] with each ]
[ t advised set-word-prop ] tri ;

1
extra/advice/authors.txt Normal file
View File

@ -0,0 +1 @@
James Cash

1
extra/advice/summary.txt Normal file
View File

@ -0,0 +1 @@
Implmentation of advice/aspects

3
extra/advice/tags.txt Normal file
View File

@ -0,0 +1,3 @@
advice
aspect
annotations

8
extra/benchmark/benchmark.factor
View File

@ -6,12 +6,12 @@ continuations debugger ;
IN: benchmark
: run-benchmark ( vocab -- result )
[ [ require ] [ [ run ] benchmark ] bi ] curry
[ error. f ] recover ;
[ [ require ] [ [ run ] benchmark ] bi ] curry
[ error. f ] recover ;
: run-benchmarks ( -- assoc )
"benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ;
"benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- )
standard-table-style [

1
extra/bunny/deploy.factor
View File

@ -4,7 +4,6 @@ H{
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-name "Bunny" }
{ deploy-word-props? f }

1
extra/hello-ui/deploy.factor Executable file → Normal file
View File

@ -8,7 +8,6 @@ H{
{ deploy-io 2 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-word-defs? f }
{ deploy-compiler? t }
{ deploy-reflection 1 }

1
extra/hello-world/deploy.factor
View File

@ -5,7 +5,6 @@ H{
{ deploy-threads? f }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-random? f }
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-ui? f }

3
extra/inverse/inverse.factor
View File

@ -131,6 +131,9 @@ MACRO: undo ( quot -- ) [undo] ;
\ pick [ >r pick r> =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
\ not [ not ] define-inverse
\ >boolean [ { t f } memq? assure ] define-inverse
\ >r [ r> ] define-inverse
\ r> [ >r ] define-inverse

1
extra/joystick-demo/deploy.factor
View File

@ -4,7 +4,6 @@ H{
{ deploy-io 2 }
{ deploy-word-defs? f }
{ deploy-c-types? t }
{ deploy-random? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ deploy-threads? t }

7
extra/lisp/lisp-docs.factor
View File

@ -1,5 +1,12 @@
IN: lisp
USING: help.markup help.syntax ;
HELP: <LISP
{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
{ $see-also lisp-string>factor } ;
HELP: lisp-string>factor
{ $values { "str" "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
{ $description "Turns a string of lisp into a factor quotation" } ;
ARTICLE: "lisp" "Lisp in Factor"
"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl

7
extra/lisp/lisp-tests.factor
View File

@ -84,4 +84,11 @@ IN: lisp.test
<LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
] unit-test
{ { 3 3 4 } } [
<LISP (defun foo (x y &rest z)
(cons (+ x y) z))
(foo 1 2 3 4)
LISP> cons>seq
] unit-test
] with-interactive-vocabs

21
extra/lisp/lisp.factor
View File

@ -64,14 +64,9 @@ PRIVATE>
: macro-expand ( cons -- quot )
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
<PRIVATE
: (expand-macros) ( cons -- cons )
[ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
PRIVATE>
: expand-macros ( cons -- cons )
dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
[ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
@ -169,15 +164,15 @@ M: no-such-var summary drop "No such variable" ;
"set" "lisp" "define-lisp-var" define-primitive
"(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
"(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
"(set 'list (lambda (&rest xs) xs))" lisp-eval
"(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
<" (defmacro defun (name vars &rest body)
(list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
(list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
"(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
"(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
;
: <LISP
"LISP>" parse-multiline-string define-lisp-builtins
lisp-string>factor parsed \ call parsed ; parsing
"LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
lisp-string>factor parsed \ call parsed ; parsing

12
extra/lisp/parser/parser-tests.factor
View File

@ -65,4 +65,16 @@ IN: lisp.parser.tests
}
} [
"(1 (3 4) 2)" lisp-expr
] unit-test
{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
"'(1 2 3)" lisp-expr cons>seq
] unit-test
{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
"'foo" lisp-expr cons>seq
] unit-test
{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
"(1 2 '(3 4) 5)" lisp-expr cons>seq
] unit-test

6
extra/lisp/parser/parser.factor
View File

@ -35,5 +35,7 @@ atom = number
| identifier
| string
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
list-item = _ ( atom | s-expression ) _ => [[ second ]]
;EBNF
list-item = _ ( atom | s-expression | quoted ) _ => [[ second ]]
quoted = squote list-item => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
expr = list-item
;EBNF

Some files were not shown because too many files have changed in this diff Show More