. 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
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 '
+++ /dev/null
-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
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
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 ;
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 ;
: ^^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
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 ;
[ ##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 ;
QUALIFIED: byte-arrays
QUALIFIED: kernel.private
QUALIFIED: slots.private
+QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: alien.accessors
kernel:eq?
slots.private:slot
slots.private:set-slot
+ strings.private:string-nth
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
{ \ 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> ] }
] [ 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 ;
[ 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 ;
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
: 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 ;
] bi* + + + + + ;
: should-inline? ( #call word -- ? )
- inlining-rank 5 >= ;
+ dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history
{ <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
[ 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
: 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> ;
! See http://factorcode.org/license.txt for BSD license.\r
IN: concurrency.mailboxes\r
USING: dlists deques threads sequences continuations\r
-destructors namespaces random math quotations words kernel\r
+destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
debugger debugger.threads locals ;\r
\r
! Concurrency library for Factor, based on Erlang/Termite style\r
! concurrency.\r
USING: kernel threads concurrency.mailboxes continuations\r
-namespaces assocs random accessors summary ;\r
+namespaces assocs accessors summary ;\r
IN: concurrency.messaging\r
\r
GENERIC: send ( message thread -- )\r
TUPLE: synchronous data sender tag ;\r
\r
: <synchronous> ( data -- sync )\r
- self 256 random-bits synchronous boa ;\r
+ self synchronous counter synchronous boa ;\r
\r
TUPLE: reply data tag ;\r
\r
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 -- )
! 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
: 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
+: aux-offset 2 cells string tag-number - ; 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 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
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
{ $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" }
{ 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
[ 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
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 )
[
] [
[ buffer-length ] keep
buffer-read f
- ] if* ;
+ ] if* ; inline
: buffer-until ( separators buffer -- byte-array separator )
swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
: 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
: 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
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 } ;
] [
pprint-object
] if ;
-
-M: tuple-layout pprint*
- "( tuple layout )" swap present-text ;
[ 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
: 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
: 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) ( -- )
\ <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
{ "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 ;
"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:"
$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."
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
-SYMBOL: deploy-random?
+SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
SYMBOL: deploy-io
{ 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 }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ 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 }
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 ;
8 num-tags set
3 tag-bits set
-18 num-types set
+17 num-types set
H{
{ fixnum BIN: 000 }
{ 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
"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
"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 ]
{ "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" }
1 exit
] if
] %
-] [ ] make bootstrap-boot-quot set
+] [ ] make
+bootstrap-boot-quot set
{ $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
{ $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
[ t ] [
T{ size-test } tuple-size
- size-test tuple-layout size>> =
+ size-test tuple-layout second =
] unit-test
GENERIC: <yo-momma>
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
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 )
"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 ;
: 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 ;
2drop f
] if ; inline
-: tuple-instance? ( object class echelon -- ? )
+: tuple-instance? ( object class offset -- ? )
#! 4 slot == superclasses>>
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 ( class -- n )
+ tuple-layout third 2 * 5 + ;
+
: define-tuple-predicate ( class -- )
- dup dup tuple-layout echelon>>
+ dup dup layout-class-offset
[ tuple-instance? ] 2curry define-predicate ;
: class-size ( class -- n )
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 ;
[ 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 -- ? )
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
- dup tuple-layout echelon>> tuple-instance? ;
+ dup layout-class-offset tuple-instance? ;
M: tuple-class (flatten-class) dup set ;
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 ;
] 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
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' )
\ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
- methods>> engines>quots* linear-dispatch-quot ;
+ [
+ [ n>> nth-superclass% ]
+ [ methods>> engines>quots* linear-dispatch-quot % ] bi
+ ] [ ] make ;
-: hash-methods ( methods -- buckets )
+: hash-methods ( n methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ <trivial-tuple-dispatch-engine> ] map ;
-
-: word-hashcode% ( -- ) [ 1 slot ] % ;
+ [ <trivial-tuple-dispatch-engine> ] with map ;
-: 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 )
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
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 ]
] assoc-map
alist>quot ;
-: tuple-layout-echelon% ( -- )
+: 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.
+ dup first first 1 = [ unclip second ] [ default get ] if swap
[
- { 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
- [ remember-engine ] [ 1quotation ] bi
- dup default set
- ] assoc-map
- ]
- [ first2 engine>quot 2array ] bi*
- suffix
- ] unless
+ engine>quot define-engine-word
+ [ remember-engine ] [ 1quotation ] bi
+ dup default set
+ ] assoc-map
+ ]
+ [ first2 engine>quot 2array ] bi*
+ suffix
] with-scope
- >=-case-quot %
+ echelon-case-quot %
] [ ] make ;
[ 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 ;
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 ;
--- /dev/null
+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"
\ No newline at end of file
--- /dev/null
+! 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
\ No newline at end of file
--- /dev/null
+! 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 ;
+
\ No newline at end of file
--- /dev/null
+James Cash
--- /dev/null
+Implmentation of advice/aspects
--- /dev/null
+advice
+aspect
+annotations
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-compiler? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-name "Bunny" }
{ deploy-word-props? f }
{ deploy-io 2 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
- { deploy-random? f }
{ deploy-word-defs? f }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ deploy-threads? f }
{ deploy-word-props? f }
{ deploy-reflection 2 }
- { deploy-random? f }
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-ui? f }
{ deploy-io 2 }
{ deploy-word-defs? f }
{ deploy-c-types? t }
- { deploy-random? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ deploy-threads? t }
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
<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
: 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 ] ;
"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
\ No newline at end of file
}
} [
"(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
\ No newline at end of file
| 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
\ No newline at end of file
{ deploy-io 2 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
- { deploy-random? t }
{ deploy-word-defs? f }
{ deploy-compiler? t }
{ deploy-reflection 1 }
USING: tools.deploy.config ;
H{
{ deploy-reflection 1 }
- { deploy-random? t }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-name "Spheres" }
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
- { deploy-random? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-random? t }
{ deploy-io 2 }
{ deploy-math? t }
{ deploy-word-defs? f }
{ deploy-compiler? t }
{ deploy-c-types? f }
{ deploy-reflection 1 }
- { deploy-random? f }
{ deploy-name "WebKit demo" }
{ deploy-io 1 }
{ deploy-math? f }
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
- case TUPLE_LAYOUT_TYPE:
- return sizeof(F_TUPLE_LAYOUT);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
#include "master.h"
+static bool full_output;
+
void print_chars(F_STRING* str)
{
CELL i;
CELL i;
bool trimmed;
- if(length > 10)
+ if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
CELL i;
bool trimmed;
- if(length > 10)
+ if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
- if(nesting <= 0)
+ if(nesting <= 0 && !full_output)
{
printf(" ... ");
return;
printf("d <addr> <count> -- dump memory\n");
printf("u <addr> -- dump object at tagged <addr>\n");
printf(". <addr> -- print object at tagged <addr>\n");
+ printf("t -- toggle output trimming\n");
printf("s r -- dump data, retain stacks\n");
printf(".s .r .c -- print data, retain, call stacks\n");
printf("e -- dump environment\n");
print_obj(addr);
printf("\n");
}
+ else if(strcmp(cmd,"t") == 0)
+ full_output = !full_output;
else if(strcmp(cmd,"s") == 0)
dump_memory(ds_bot,ds);
else if(strcmp(cmd,"r") == 0)
#define BYTE_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11
#define STRING_TYPE 12
-#define TUPLE_LAYOUT_TYPE 13
+#define WORD_TYPE 13
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
-#define WORD_TYPE 17
-#define TYPE_COUNT 20
+#define TYPE_COUNT 17
INLINE bool immediate_p(CELL obj)
{
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
-/* C sucks. */
+/* We use a union here to force the float value to be aligned on an
+8-byte boundary. */
union {
CELL header;
long long padding;
CELL size;
} F_STACK_FRAME;
+/* These are really just arrays, but certain elements have special
+significance */
typedef struct
{
CELL header;
- /* tagged fixnum */
- CELL hashcode;
+ /* tagged */
+ CELL capacity;
/* tagged */
CELL class;
/* tagged fixnum */
CELL size;
- /* tagged array */
- CELL superclasses;
/* tagged fixnum */
CELL echelon;
} F_TUPLE_LAYOUT;
primitive_array_to_quotation,
primitive_quotation_xt,
primitive_tuple,
- primitive_tuple_layout,
primitive_profiling,
primitive_become,
primitive_sleep,
return result;
}
-/* Tuple layouts */
-DEFINE_PRIMITIVE(tuple_layout)
-{
- F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
- layout->echelon = dpop();
- layout->superclasses = dpop();
- layout->size = dpop();
- layout->class = dpop();
- layout->hashcode = untag_word(layout->class)->hashcode;
- dpush(tag_object(layout));
-}
-
/* Tuples */
/* push a new tuple on the stack */
DEFINE_PRIMITIVE(tuple)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = to_fixnum(layout->size);
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
F_FIXNUM i;
DEFINE_PRIMITIVE(tuple_boa)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = to_fixnum(layout->size);
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_tuple(layout);
projects / factor.git / commitdiff